vba 対象セルが空白の間動作を繰り返すには？

質問

下記を走らせると、セルが右端まで行ってとまります。
そうなる前に、対象セル範囲が空白になった時点で、動作を止めたいのですが
どう記述するのがいいでしょうか？

Dim u As Integer, o As Integer

Application.Calculate

For u = 2 To 3
For o = 7 To 2000

If Cells(u, o) = "" Then

Range("G2").Select
Range("G2").End(xlToRight).Select
ActiveCell.Resize(6, 5).Select
Selection.Cut
Range("B2").Select
Range("B2").End(xlDown).Select
ActiveCell.Offset(1).Select
ActiveSheet.Paste

End If

Next o
Next u

End Sub

回答No.2

shirokuma2014 · ベストアンサー

あ、しまった。
frag初期化するの忘れてました。

■修正版
-------

Sub sample()
Dim u As Integer, o As Integer, c As Range, frag As Boolean

Application.Calculate

For u = 2 To 3
For o = 7 To 2000
frag = False

If Cells(u, o) = "" Then

Range("G2").Select
Range("G2").End(xlToRight).Select
If Selection.Value <> "" Then
ActiveCell.Resize(6, 5).Select
For Each c In Selection
If c.Value <> "" Then
frag = True
Exit For
End If
Next

If Not frag Then
Exit Sub
End If
Else
Exit Sub
End If
Selection.Cut
Range("B2").Select
Range("B2").End(xlDown).Select
ActiveCell.Offset(1).Select
ActiveSheet.Paste

End If

Next o
Next u

End Sub

お礼

ありがとうございます！

私がVBA勉強し始めたばかりで、かなり変な形になってると思います。
先に進めました。

回答No.1

shirokuma2014

こんにちは！

G2を基準にして右End移動し、指定した範囲をコピーして、B2を基準にして下End移動した一番したのセルにペーストするのですか？？

なぜこういう業務が必要なのかよく分かりませんが、
エクセルの基本機能である「コピー」→「行列入れ替えて貼り付ける」で実現可能な気も…。

表がどういう構造をしているのかよく分からないのですけど、今のまま実行すると
ActiveCell.Resize(6, 5).Select
の行で再右端に行ってエラーになりませんか？

公開されているコードに付加する形でコードを書きました。
(されたいことをほとんど推測で書いてますので、意図した通りに動かないかも)

ForNextとCellsを習得されているのなら、次は
Cells(u,o).value = Cells(o,u+1).value
のような書き方を覚えられるのをオススメします。
おそらく2,3行になります。

-----

Sub sample()
Dim u As Integer, o As Integer, c As Range, frag As Boolean

Application.Calculate

For u = 2 To 3
For o = 7 To 2000

If Cells(u, o) = "" Then

Range("G2").Select
Range("G2").End(xlToRight).Select
If Selection.Value <> "" Then
ActiveCell.Resize(6, 5).Select
For Each c In Selection
If c.Value <> "" Then
frag = True
Exit For
End If
Next

If Not frag Then
Exit Sub
End If
Else
Exit Sub
End If
Selection.Cut
Range("B2").Select
Range("B2").End(xlDown).Select
ActiveCell.Offset(1).Select
ActiveSheet.Paste

End If

Next o
Next u

End Sub