Excel VBA 空白をセルを探して貼り付け

ネットで似たようなコードを探して
自分なりにアレンジしたのですが
貼り付けた後もループしてしまいます。

どこがおかしいのか教えて下さい。

Sub 貼り付け()
Dim pastrange As Range
Dim copyrange As Range
Dim rc
Dim cc
Dim Flag As Boolean
Dim c As Variant

rc = Selection.Rows.Count
cc = Selection.Columns.Count

Application.ScreenUpdating = False

Set copyrange = Selection
Set pastrange = Sheets("Sheet1").Range("G3")
copyrange.Copy

Sheets("Sheet1").Range("G3").Activate
Flag = False
Do Until Flag

For Each c In ActiveCell.Resize(rc, cc)
If IsEmpty(c) Then
Flag = True
Else

Flag = False
ActiveCell.Offset(1, 0).Activate
Exit For
End If
Next c
Loop

ActiveSheet.Paste
Application.CutCopyMode = False
Application.ScreenUpdating = True

よろしくお願いします。

質問者からの補足コメント

• マクロを実行したい表を添付します

  
    補足日時：2020/06/07 22:56

No.2 ベストアンサー 回答者： tom04 回答日時： 2020/06/07 22:43

No.1です。

投稿後お示しのコードを再確認してみました。
G列に空白セルがあっても、選択範囲の行数・列数内にすでにデータがある場合は
その行に貼り付けるのではなく、貼り付け範囲があるところにペーストする！というコトなのでしょうかね。

そうであれば、前回のコードは消去し↓のコードに変更してみてください。

Sub Sample2()
　Dim i As Long
　Dim myRow As Long, myCol As Long
　　myRow = Selection.Rows.Count
　　myCol = Selection.Columns.Count
　　　For i = 3 To Cells(Rows.Count, "G").End(xlUp).Row
　　　　If Cells(i, "G") = "" Then
　　　　　If WorksheetFunction.CountA(Cells(i, "G").Resize(myRow, myCol)) = 0 Then
　　　　　　Exit For
　　　　　End If
　　　　End If
　　　Next i
　　　　Selection.Copy Cells(i, "G")
End Sub

今度はどうでしょうか？m(_ _)m

この回答へのお礼

すごいです。
やりたかったことが出来ました。
本当にありがとうございます。

お礼日時：2020/06/07 23:13

No.1 回答者： tom04 回答日時： 2020/06/07 22:00

こんばんは！

こんな感じのコトをやりたいのでしょうか？

Sub Sample1()
　Dim i As Long
　　For i = 3 To Cells(Rows.Count, "G").End(xlUp).Row
　　　If Cells(i, "G") = "" Then Exit For
　　Next i
　　　Selection.Copy Cells(i, "G")
End Sub

※　的外れならごめんなさい。m(_ _)m

この回答へのお礼

ありがとうございます。
このコードでは貼り付けたいセル範囲が
全て空白か判定されないんですよ。

貼り付けたいところが疎らに空白になっているので
悩んでいます。

お礼日時：2020/06/07 22:46