空白行を見つけ貼り付けて埋める

投稿者 : 質問者     投稿日時 : 2024/12/16(Mon) 23:31:55     OS : 未指定     EXCEL : 未指定

---

拙い説明で恐縮ですが、ご教示ください。

例
H列のH8～H12セルの値を消し、空白ができる。
空白行すぐ下のH13～L27範囲を空白行最初（H8）を始点に張り付ける。

値を消すセルは毎回異なる。
空白範囲を見つけ、空白行最終行すぐ下の値があるセルを始点に、D列最終行までの範囲をコピーし、空白行最初（H8）を始点に張り付けたい。

こうしたマクロの作成方法を指導いただけると幸いです。
よろしくお願いいたします。

参考画像1（マクロ実行前イメージ）：https://ibb.co/3Spqf0F
参考画像2（マクロ実行後イメージ）：https://ibb.co/x19fXvn

投稿者 : てらてら     投稿日時 : 2024/12/17(Tue) 06:16:16

---

こんにちは。

「空白行を見つけ貼り付けて埋める」
ではなく、
「空白行を見つけて削る」
になりますが、参考にしてみてください。

Sub macro()
    Dim i As Long, delLine As Long, copyLine As Long
    Dim b As Boolean
    b = False
    For i = 1 To ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row
        
        If Cells(i, "H") = "" And b = False Then
            delLine = i
            b = True
        End If
        
        If b And Cells(i, "H") <> "" Then
            copyLine = i
            Exit For
        End If
        
    Next i
    
    If b = False Then Exit Sub
    
    Range("H" & delLine).Resize(copyLine - delLine, 5).Select
    Selection.Delete Shift:=xlUp
End Sub

投稿者 : さんこう     投稿日時 : 2024/12/17(Tue) 09:42:05

---

＞空白範囲を見つけ、空白行最終行すぐ下の値があるセルを始点に、D列最終行までの範囲をコピーし、空白行最初（H8）を始点に張り付けたい。

想定通りにはならないようですが、↑をコードにするとこんな感じになるかと思います。

参考になれば。

Sub Test()
    Dim 空白行最初 As Long
    Dim すぐ下の値があるセル As Long
    Dim D列最終行 As Long
    
    For r = 1 To Cells(Rows.Count, "H").End(xlUp).Row
        If Cells(r, "H") = "" And 空白行最初 = 0 Then 空白行最初 = r
        If Cells(r, "H") <> "" And 空白行最初 <> 0 And すぐ下の値があるセル = 0 Then すぐ下の値があるセル = r
    Next
    
    D列最終行 = Cells(Rows.Count, "D").End(xlUp).Row
    
    MsgBox Cells(すぐ下の値があるセル, "H").Address(False, False) & ":" & Cells(D列最終行, "D").Address(False, False) & "の範囲をコピーし、" _
            & Cells(空白行最初, "H").Address(False, False) & "を始点に張り付けましょう"
            
    'Range(Cells(すぐ下の値があるセル, "H"), Cells(D列最終行, "D")).Copy Cells(空白行最初, "H")
End Sub

投稿者 : ピロリ     投稿日時 : 2024/12/17(Tue) 18:09:43

---

もし、空白行が飛び飛びに複数行存在するのなら、下のような感じでも。　ご参考まで。

Sub Sample()
    Dim i As Long
    Dim flg As Boolean, del_top As Long
    
    flg = False
    For i = 3 To Cells(Rows.Count, "H").End(xlUp).Row
        If Cells(i, "H") = "" And flg = False Then
            flg = True
            del_top = i
        ElseIf Cells(i, "H") <> "" And flg = True Then
            Cells(del_top, "H").Resize(i - del_top, 5).Delete Shift:=xlUp
            flg = False
            i = del_top
        End If
    Next i
End Sub

投稿者 : 質問者     投稿日時 : 2024/12/19(Thu) 00:08:31

---

てらてら様。さんこう様。ピロリ様。
お三方、ご教授いただき感謝です。
色々な方法お聞きでき解決しました。
ありがとうございました。