Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9803 / 76734

←次へ　｜　前へ→


	【72488】Re:sheet1のデータをsheet2に整形して抽出する方法

タケル - 12/8/15(水) 22:36 -


	引用なし

	パスワード

UO3さんへ
欲しい処理ができました。
ありがとうございます。
ただ、もう少しこうしたほうが処理が速くなるとか、
何かアドバイスがいただければ幸いです。

それから、sheet1にデータがなくなったときに
処理を終わらせるためには、どうしたらよろしいでしょうか？

--------------------------------------------------------------------------

Sub コピペ()

i = 2
j = 2

m = 2
n = 3
o = 4
p = 5
q = 6
r = 7

p01:
If Cells(i, "A") = "" Then
　　 Sheets(1).Cells(i + 1, "A").Copy Sheets(2).Cells(j, "A")
　　 Sheets("sheet2").Select
　　 Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True 'アプリケーション定義またはオブジェクト定義のエラー（上手く行く時もある）
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Cells(i + 1, "B").Copy Sheets(2).Cells(j, "B")
　　 Sheets("sheet2").Select
　　 Sheets(2).Range(Cells(j, "B"), Cells(j + 5, "B")).MergeCells = True
　　 Sheets("sheet1").Select

　　 Sheets(1).Cells(i + 1, "J").Copy Sheets(2).Cells(j + 1, "V")
　　 Sheets(1).Cells(i + 1, "K").Copy Sheets(2).Cells(j + 3, "V")
　　 Sheets(1).Cells(i + 2, "K").Copy Sheets(2).Cells(j + 4, "V")
　　 Sheets(1).Cells(i + 3, "K").Copy Sheets(2).Cells(j + 5, "V")
　　　　　
　　 j = j + 6

　　 Y = Sheets("sheet1").Cells(i + 1, "B").Value
　　
　　 Sheets(1).Range(Cells(i + 1, "D"), Cells(i + Y, "D")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(m, 4), Cells(m, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 m = m + 6
　　 Sheets("sheet1").Select
　　
　　
　　 Sheets(1).Range(Cells(i + 1, "E"), Cells(i + Y, "E")).Select 'アプリケーション定義またはオブジェクト定義のエラーが発生
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(n, 4), Cells(n, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 n = n + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "F"), Cells(i + Y, "F")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(o, 4), Cells(o, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 o = o + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(p, 4), Cells(p, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 p = p + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "H"), Cells(i + Y, "H")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(q, 4), Cells(q, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 q = q + 6
　　 Sheets("sheet1").Select
　　
　　 Sheets(1).Range(Cells(i + 1, "I"), Cells(i + Y, "I")).Select
　　 Selection.Copy
　　 Sheets(2).Select
　　 Range(Cells(r, 4), Cells(r, 4 + Y)).Select
　　 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　False, Transpose:=True
　　 r = r + 6
　　 Sheets("sheet1").Select
　　
Else
End If
i = i + 1
GoTo p01
End Sub

--------------------------------------------------------------------------

3 hits

▼

【72481】sheet1のデータをsheet2に整形して抽出する方法 タケル 12/8/15(水) 14:45