Excel 指定値だけ行コピー＋値の移動

Excel 2010でSheet1に次のような表があります。

　Ａ列　　Ｂ列　Ｃ列　Ｄ列　Ｅ列
　りんご　111　　222　333　444
　みかん　555　　666
　いちご　777　　888　999
　　・
　　・
　　・
これをマクロを使って、次のような形にしたいと思います。
1.Ｃ列以降の「数値が入った列数分だけ」行コピーをする。（最大９列まで）
　（この例の場合りんごの行は3回、みかんの行は1回、いちごの行は2回）
2.次にＣ列以降の数値はコピーした行のＢ列に移動する。

マクロ実行後は次のようになります。
　Ａ列　　Ｂ列
　りんご　111
　りんご　222
　りんご　333
　りんご　444
　みかん　555
　みかん　666
　いちご　777
　いちご　888
　いちご　999
　　・
　　・
　　・
膨大な数のデータですので、マクロを使って処理したいと思っています。
どうぞよろしくお願いいたします。

No.5 ベストアンサー 回答者： tom04 回答日時： 2011/07/02 21:44

こんばんは！

お望みの方法と違うかもしれませんが・・・
別Sheetに表示する方法の一例です。
Sheet1のデータをSheet2に表示するようにしてみました。

尚、データは2行目からとしています。

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
'↑データが1行目からの場合は「2」を「1」に変更
For j = 2 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.Offset(, 1) = ws1.Cells(i, j)
End With
Next j
Next i
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答への補足

回答ありがとうございます。この方法が元データもSheet1に残っていて、1番良いように思います。
実際のデータはB～K列の10列に各支店での商品在庫数が入ってきます。間違って元データのL列にも数値が入っていた場合も、行コピーと数値の移動はされるのでしょうか。

補足日時：2011/07/03 01:44

No.9 回答者： tom04 回答日時： 2011/07/03 13:00

No.5・6・7です！

補足を読ませていただきました。
＞
実際仕事で使っている表はいろいろな項目があり、数値を移動させる列はH列以降となり、A～F列までの内容が行コピーされるというふうにしたいのです

と言うコトですので・・・
↓の画像のような感じでよいのでしょうかね？
もしそうであれば無理矢理って感じのコードです。
For～Nextを多用していますので結構時間がかかるかもしれません。

Sub test()
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Cells.Clear
Range(ws1.Cells(1, 1), ws1.Cells(1, 7)).Copy
ws2.Activate
ws2.Cells(1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 8 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column
With ws2.Cells(Rows.Count, 7).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 7)
.Offset(, 1) = ws1.Cells(i, j)
End With
Next j
Next i
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To ws2.Cells(Rows.Count, 7).End(xlUp).Row
For k = 1 To 6
If ws1.Cells(i, 7) = ws2.Cells(j, 7) Then
ws2.Cells(j, k) = ws1.Cells(i, k)
End If
Next k
Next j
Next i
ws2.Columns("A:H").AutoFit
End Sub

尚、各行のデータがある最終列までを表示するようにしていますので、
もしSheet1の列数に指定がある場合は

＞For j = 8 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column

部分で調整してみてください。
（「8列目～その行の最終列まで」というコードになります）

以上、長々と失礼しました。m(_ _)m

この回答へのお礼

スクリーンキャプチャまで使って説明していただき、ありがとうございます。

＞For～Nextを多用していますので結構時間がかかるかもしれません。
やはり複雑になってしまうのですね。結局、質問にあるように最低限の項目だけに表を加工してから、次のようにするのが良いのかもしれません。
1.No.5のマクロを実行
2.項目（列）を挿入
3.空白のセルに元データからvlookup関数で値を挿入する。

とても丁寧な回答ありがとうございました。

お礼日時：2011/07/03 19:28

No.8 回答者： keithin 回答日時： 2011/07/03 04:01

＞実行時エラー

ご質問で掲示されたのとは違うパターンで数字が入っている(入っていない）ようです。

sub macro1r1()
　dim r as long
　dim n as long

　for r = range("B65536").end(xlup).row to 1 step -1
　　n = application.count(range(cells(r, "C"), cells(r, "K")))
　　if n > 0 then
　　cells(r + 1, "A").resize(n, 1).entirerow.insert
　　cells(r + 1, "A").resize(n, 1).value = cells(r ,"A").value
　　cells(r, "C").resize(1, n).copy
　　cells(r + 1, "B").pastespecial transpose:=true
　　end if
　next r
　range("C:K").delete shift:=xlshifttoleft
end sub



＃まぁ，使わないのでしたら捨ててくださいとしか言いようがありませんが。

この回答へのお礼

補足への回答ありがとうございます。
今回は急ぎで処理しなければならないデータのため、結果ばかりを追い求めてしまいましたが、今後はステートメントの意味を理解して自分で応用できるようになりたいと思います。

お礼日時：2011/07/03 19:38

No.7 回答者： tom04 回答日時： 2011/07/02 22:39

No.5・6です！

何度もごめんなさい。

No.6のコードで
＞Do Until L = i + j - 1
の行を
＞Do Until L = i + k - 1
に訂正してください。

検証せずに投稿してごめんなさいね。m(_ _)m

この回答への補足

tom04さん、訂正ありがとうございます。
実際仕事で使っている表はいろいろな項目があり、数値を移動させる列はH列以降となり、A～F列までの内容が行コピーされるというふうにしたいのです。

No.5の別シートに出力する方法で、どういう風にマクロを変更すればよいのか教えていただけますでしょうか。

補足日時：2011/07/03 03:25

No.6 回答者： tom04 回答日時： 2011/07/02 22:20

No.5です！

もう一案

同一Sheetで処理する場合のコードの一例です。
今回もデータは2行目からとしています。

Sub test2()
Dim i, j, k, L As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'↑データが1行目からであれば「2」を「1」に変更
j = Cells(i, Columns.Count).End(xlToLeft).Column
If j > 2 Then
Rows(i + 1 & ":" & i + j - 2).Insert
End If
L = i + 1
For k = 3 To j
Do Until L = i + j - 1
With Cells(L, 1)
.Value = Cells(i, 1)
.Offset(, 1) = Cells(i, k)
End With
L = L + 1
Loop
Next k
Next i
Columns("C:K").Delete
End Sub

何度も失礼しました。m(_ _)m

この回答へのお礼

ありがとうございます。
質問した時点では、この回答のように元データを変更するマクロを考えていたのですが、No.5の別シートに出力する方法も良いですね。
マクロについていろいろ勉強になりました。これでだいぶ仕事がはかどります。

お礼日時：2011/07/03 02:23

No.4 回答者： KURUMITO 回答日時： 2011/07/02 21:42

回答No１です。

失礼しました。別のシートのA２セルには次の式を入力しB２セルまでオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>MAX(Sheet1!$J:$J),"",IF(COLUMN(A1)=1,INDEX(Sheet1!$A:$A,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1),INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COUNTIF($A$2:$A2,$A2)+1)))

No.3 回答者： imogasi 回答日時： 2011/07/02 21:30

Sub test01()

Dim sh1, sh2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("a65536").End(xlUp).Row
k = 1
For i = 1 To d
c = sh1.Range("z" & i).End(xlToLeft).Column
'MsgBox c
For Each cl In sh1.Range(sh1.Cells(i, 2), sh1.Cells(i, c))
MsgBox cl
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = cl
k = k + 1
Next
Next i
End Sub
ーー
最も右の列は「Z列を仮定、適当に変えて。

この回答への補足

回答ありがとうございます。

試したところ、sheet2に出力されるのですが、B列以降の内容が全てメッセージボックスに表示されてしまいます。
今回はtom04さんのマクロを使用してみることにしますが、参考にさせていただきます。
素早い回答ありがとうございました。

補足日時：2011/07/03 02:19

No.2 回答者： keithin 回答日時： 2011/07/02 21:22

sub macro1()

　dim r as long
　dim n as long

　for r = range("B65536").end(xlup).row to 1 step -1
　　n = application.count(range(cells(r, "C"), cells(r, "K")))
　　cells(r + 1, "A").resize(n, 1).entirerow.insert
　　cells(r + 1, "A").resize(n, 1).value = cells(r ,"A").value
　　cells(r, "C").resize(1, n).copy
　　cells(r + 1, "B").pastespecial transpose:=true
　next r
　range("C:K").delete shift:=xlshifttoleft
end sub

この回答への補足

回答ありがとうございます。

試してみたところ、値の「移動」ではなく「コピー」となってしまうようです。
また、実行時エラー'1004':アプリケーション定義またはオブジェクト定義のエラーです。
と表示されてしまいます。

補足日時：2011/07/03 01:59

No.1 回答者： KURUMITO 回答日時： 2011/07/02 21:21

マクロを使わなくとも関数で十分対応できますね。

次のようにします。
お示しのデータがシート１に有って１行目は項目名で２行目以降に各データが入力されているとします。
１０列目のJ列は作業列としてJ１セルには０を入力します。その後にJ２セルには次の式を入力して下方にオートフィルドラッグします。

=IF(A2="","",COUNTA(B2:I2)+J1)

データが多くてオートフィルドラッグが容易でなければJ２セルを選択して右クリックから「コピー」したのちに「名前ボックス」にJ２と表示されているところで例えばJ２:J５０００と入力してEnterをすれば２行目から５０００行まで選択状態になりますので右クリックして貼り付けをすればJ２セルからJ５０００までオートフィルドラッグ操作を行ったことになります。

その後にお求めの表ですが別のシートに表示させるとして１行目はシート１と同じ項目名としてA２セルには次の式を入力してI２セルまでオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>MAX(Sheet1!$J:$J),"",IF(COLUMN(A1)=1,INDEX(Sheet1!$A:$A,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1),IF(INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COLUMN(A1))=0,"",INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COLUMN(A1)))))

これでお求めの表が完成します。

この回答へのお礼

回答ありがとうございます。

マクロを使わなければできないと思っていただけに、関数だけでできるとは気がつきませんでした。こちらも参考にさせていただきます。

素早い回答ありがとうございました。この考え方を元にいろいろ応用できそうですね。

お礼日時：2011/07/03 02:29