Excel VBA查找空行后复制其上方两行并粘贴的实现问题求助

现有代码问题点 #

• 多余的空行赋值、弹窗逻辑会破坏空行标记，影响定位准确性
• 仅选中空行上方第2行的单条行数据，未覆盖要求的2行复制范围
• 插入位置逻辑偏差，导致粘贴结果不符合预期

修正后代码 #

Sub Find_Copy()
    Dim rCell As Range
    Dim rngCopy As Range
    
    ' 调用现有自定义函数定位空行，无需调整
    Set rCell = FindNextEmpty(Range("B8"))
    
    If Not rCell Is Nothing Then
        ' 选中空行上方的连续2行
        Set rngCopy = rCell.Offset(-2, 0).Resize(2, 1).EntireRow
        ' 复制选中行
        rngCopy.Copy
        ' 在选中行下方（空行上方）插入复制内容
        rngCopy.Offset(2, 0).Insert Shift:=xlDown
        ' 清空剪贴板，取消选中状态
        Application.CutCopyMode = False
    End If
    
    ' 释放对象
    Set rngCopy = Nothing
    Set rCell = Nothing
End Sub

批量处理所有空行的扩展版本 #

如果需要一次性处理表格内所有符合要求的空行，可以使用循环版本：

Sub Find_Copy_All()
    Dim rCell As Range
    Dim rngCopy As Range
    Dim startSearch As Range
    
    Set startSearch = Range("B8")
    Do
        Set rCell = FindNextEmpty(startSearch)
        If rCell Is Nothing Then Exit Do
        
        ' 确保空行上方至少有2行数据，避免报错
        If rCell.Row > 2 Then
            Set rngCopy = rCell.Offset(-2, 0).Resize(2, 1).EntireRow
            rngCopy.Copy
            rngCopy.Offset(2, 0).Insert Shift:=xlDown
            Application.CutCopyMode = False
        End If
        ' 从当前空行下一行开始搜索下一个空行
        Set startSearch = rCell.Offset(1, 0)
    Loop
    
    Set rngCopy = Nothing
    Set rCell = Nothing
    Set startSearch = Nothing
End Sub

逻辑说明 #

1. Resize(2,1) 表示从偏移定位的起始行开始，向下扩展选中2行，刚好覆盖需要复制的范围
2. 插入位置选择复制范围向下偏移2行的位置，刚好插入在原始2行和空行之间，符合需求
3. 增加了空值判断，避免找不到空行时出现运行报错

内容的提问来源于stack exchange，提问作者dmt