(マクロ)カット&ペーストを列毎に繰り返したい

下のように、A列から50列目までデータが入力されています。
各列、データは上から順に詰まっている状態です。
C列のように1つもデータが入力されていない列もあります。

------------------------------------------
A列B列C列D列　・・・
Z001Z003Z004
Z002Z005
------------------------------------------

これを、「B列から順にデータをカットして、A列最終行の下にペーストする」という作業を、各列毎に50列目まで繰り返したいと思っています。
完成イメージは下記のようになります。

------------------------------------------
A列B列C列D列　・・・
Z001
Z002
Z003
Z004
Z005
------------------------------------------

下記のようにマクロを組みましたが、無限ループになっているのか、強制終了となってしまいます。
どういうふうにマクロを組めばいいのでしょうか？
宜しくご教授お願いいたします。

Sub ADD()

Dim i, j As Long

For j = 2 To 50 '列番号指定


'B列1行目から順にセルが空白でなければカットする。

i = 1

Do While Cells(i, j).Value <> Empty

Cells(i, j).Select
Selection.Cut

'A列の最終行の1つ下の行に貼り付ける。。

Range("A1").Select
Range(Selection, Selection.End(xlDown).Offset(1, 0)).Select
ActiveSheet.Paste

i = i + 1

Loop

Next

End Sub

No.4 回答者： m3_maki 回答日時： 2012/03/17 15:24

文字通り、列毎に繰り返します。

Sub test()
Dim i As Long
For i = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, i) <> "" Then
　　　　Range(Cells(1, i), Cells(Rows.Count, i).End(xlUp)).Cut Destination:=Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　End If
Next
End Sub

この回答へのお礼

ありがとうございます！解決できました。

お礼日時：2012/03/18 05:01

No.3 ベストアンサー 回答者： tom04 回答日時： 2012/03/17 14:09

こんにちは！

横からお邪魔します。

Sub test()
Dim i, j As Long
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, j).End(xlUp).Row
If Cells(i, j) <> "" Then
Cells(i, j).Cut Destination:=Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Next i
Next j
End Sub

列数が50列と決まっているのであれば
＞ For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
の行を
＞ For j = 2 To 50
に訂正してください。

※　このコードですと、質問にあるように001・002・003・004・005
の順ではなく、005・004の順が逆になりますが・・・

こんな感じで良いのでしょうか？m(_ _)m

この回答へのお礼

ありがとうございます！完璧でした！

お礼日時：2012/03/18 05:00

No.2 回答者： kybo 回答日時： 2012/03/17 07:49

>Range(Selection, Selection.End(xlDown).Offset(1, 0)).Select

では、A1のセルから、A列の最終行の1つ下までの範囲を範囲選択してしまいます。

Selection.End(xlDown).Offset(1, 0).Select

です。

御提示のコードでは、B1→B2→C1・・という順序になってしまうので、行方向に対して最初にループすればよろしいかと思います。


Sub ADD()
Dim i As Long, j As Long, r As Long
'B列の最終行を求める
r = Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To r
For j = 2 To 50 '列番号指定
Do While Cells(i, j).Value <> Empty
'B列1行目から順にセルが空白でなければカットする。
Cells(i, j).Select
Selection.Cut
'A列の最終行の1つ下の行に貼り付ける。。
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Loop
Next
Next
End Sub

この回答へのお礼

ご回答ありがとうございます！マクロ動きました！

私の質問で、処理前のデータの状態がわかりずらくて大変申し訳なかったのですが、

処理前のデータは、A列から50列目まで下のような形でデータが入っております。

------------------------------------------
A列　　B列　　C列　・・・
Z　　　　Z　　　 Z　　
Z　　　　　　　 　Z
　　　　　　　 　　Z　　
------------------------------------------

上の例ですと、A列は2行目まで、B列は1行目まで、C列は3行目までデータが入っていますが、実際は、各列ともに何行目までデータが入っているか不明なのです(但し、A列には必ず何行かデータが入っています)。

というわけでして、ご教授いただいた、

r = Range("B" & Rows.Count).End(xlUp).Row

ですと、B列より他の列の方がデータの行数が多い場合には上手くいきませんでした。。

試行錯誤で、

r = Cells(Rows.Count, j).End(xlUp).Row

などとしてみましたが、エラーとなってしまいました。。

お手数おかけしますが、こちら、ご教授頂けたらと思います。

どうぞよろしくお願いいたします。

お礼日時：2012/03/17 11:00

No.1 回答者： nobu_suzuki1 回答日時： 2012/03/17 04:55

Range("A1").Select

およびその下の
Range(Selection, Selection.End(xlDown).Offset(1, 0)).Select

がそもそも間違っていませんか？

目的に沿うようにするのであれば、例えば
Range("A65536").Select
Range(Selection, Selection.End(xlUｐ).Offset(1, 0)).Select

として実行してみてください。

この回答へのお礼

早々のご回答ありがとうございました！ご指摘どおりでした。ありがとうございます。

お礼日時：2012/03/17 11:01