空白セルをとばして転記

質問

Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ
１　リンゴ　　　　　　　　リンゴ　　
２　　　　　　　　　　　 　 ミカン　　
３　ミカン　　　　　　　　バナナ　
４
５
６　バナナ
７

上記のように、空白のセルをとばして（詰めて）転記するにはどうすれば良いでしょうか？

Dim n as long
Dim k as long

k = Range("A" & Rows.Count).End(xlUp).Row

For n = 1 To k

If Cells(n, 1) <> "" Then
Cells(n, 4) = Cells(n, 1)
n = n + 1

End If
Next n

とやると当然ながらD1のセルのみにしか転記できません
Ａ列の範囲を取得し、PasteSpecialのSkipBlanksで貼り付けてもうまくいきませんでした

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

回答No.1

nao-y · ベストアンサー

nはA列用のカウンタですよね？
D列用のカウンタを準備すればOKです。
具体的には

Sub test()
Dim n As Long
Dim k As Long
Dim l As Long

k = Range("A" & Rows.Count).End(xlUp).Row
l = 1

For n = 1 To k

If Cells(n, 1) <> "" Then
Cells(l, 4) = Cells(n, 1)
l = l + 1

End If
Next n
End Sub

となります。
（n=n+1はfor文の中なので不要ですね）

お礼

おお！ありがとうございます！
思うとおりに動きました！

変数をもう一つ置くという事は思いついてはいたのですが、
For NextとＩｆの文脈でどう処理していくかが分からなかったので、
目からうろこです。

早速のご回答大変助かりました。ありがとうございました。

回答No.2

mu2011

一例です。

Sub sample()
Dim i As Long, n As Long
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A") <> "" Then
n = n + 1
Cells(n, "D") = Cells(i, "A")
End If
Next
End Sub

お礼

ご回答ありがとうございます！
思い通りになりました

やはりD列用の変数を用意するのですね

Forの宣言部分で範囲を指定出来るというのは新発見です

いくら頭をひねっても出てこなかった答えが何通りもあるという
事で自分の未熟さが恥ずかしい限りです

とても勉強になりました。ありがとうございました