エクセルマクロで行を変えて千回カット＆ぺースト

質問

下記のコードでB,C,D・・・と行を1,000回変えて同じ作業をしたいのですが、どのようにしたらよいか分かりません。
どなたかお詳しい方アドバイスをお願いします。

Range("A18:A32").Select
Selection.Cut Destination:=Range("B3:B17")　←B,C,D・・と変えてカットしたい。
Rows("18:32").Select
Selection.Delete Shift:=xlUp
Range("A18:A32").Select
Selection.Cut Destination:=Range("C3:C17")
Rows("18:32").Select
Selection.Delete Shift:=xlUp
Range("A18:A32").Select
Selection.Cut Destination:=Range("D3:D17")
Range("D3:D17").Select
End Sub

回答No.4

weboner · ベストアンサー

やりたいことはA列のデータを15行区切りで横方向に並び替えですよね？

Sub test()
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
TC = 2
For Each l In Range("A18").Resize(MaxRow - 18)
If ((l.Row - 3) Mod 15) = 0 Then
Cells(3, TC).Resize(15).Value = l.Resize(15).Value
TC = TC + 1
End If
Next
Range("A18").Resize(MaxRow - 17).Delete
End Sub

A列最終行まで並び替え後にA18以下を削除しています

回答No.3

tom04

No.2です。

投稿後もう一度コードを読み返してみました。
行すべてを削除しなくてはならないのですね？

その場合は前回のSample2のコードの
＞Range(Cells(3, "A"), Cells(lastRow, "A")).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
の行を
＞Range(Cells(3, "A"), Cells(lastRow, "A")).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
に変更してみてください。

Sample1の場合は
＞ Range("A18:A32").Delete Shift:=xlUp
が
＞ Rows("18:32").Delete Shift:=xlUp
とします。

どうも失礼しました。m(_ _)m

回答No.2

tom04

こんばんは！
質問のコードをそのままやれば

Sub Sample1()
Dim cnt As Long
For cnt = 1 To 1000
Range("A18:A32").Cut Cells(3, cnt + 1)
Range("A18:A32").Delete Shift:=xlUp
Next cnt
MsgBox "処理完了"
End Sub

といった感じになると思いますが、
これではかなりの時間を要すると思います。
書式を無視して、値だけでよいのであればもっと時間短縮が可能だと思います。

Sub Sample2()
Dim i As Long, cnt As Long, lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 18 To lastRow Step 15
cnt = cnt + 1
Cells(3, cnt + 1).Resize(15).Value = Cells(i, "A").Resize(15).Value
Cells(i, "A").Resize(15).ClearContents
If cnt = 1000 Then Exit For
Next i
Range(Cells(3, "A"), Cells(lastRow, "A")).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
MsgBox "処理完了"
End Sub

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

回答No.1

mshr1962

Offsetを使えばいいのでは？

For i = 1 To 1000
Range("A18:A32").Select
Selection.Cut Destination:=Range("A3:A17").Offset(0, i)
Rows("18:32").Select
Selection.Delete Shift:=xlUp
Next i