|
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
--------------------------------------------------------------------------
|
|