Excel VBA需求：复制匹配行的下一行至另一工作表对应列

现有Excel VBA代码可查找包含关键词（Water、Fighter、Demon）的行并复制到sheet19，运行正常。需要修改代码实现复制匹配行的下一行并粘贴到目标工作表对应列，尝试.Copy .Offset(1)未成功，解决方案如下：

修改后的完整代码 #

Option Explicit

Sub SearchForNextRow()

    Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr As String

    On Error GoTo Err_Execute

    ' 定义要查找的关键词数组
    arr = Array("Water", "Fighter", "Demon")

    With Worksheets("Data")

        ' 遍历关键词数组
        For a = LBound(arr) To UBound(arr)
            ' 查找第一个匹配项
            Set fnd = .Columns("A").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                         MatchCase:=False, SearchFormat:=False)
            If Not fnd Is Nothing Then
                ' 记录第一个匹配项的地址，防止无限循环
                addr = fnd.Address
                Do
                    ' 检查匹配行不是最后一行，避免下一行不存在
                    If fnd.Row < .Rows.Count Then
                        ' 初始化或合并要复制的下一行区域
                        If cpy Is Nothing Then
                            Set cpy = fnd.Offset(1).EntireRow
                        Else
                            Set cpy = Union(cpy, fnd.Offset(1).EntireRow)
                        End If
                    End If

                    ' 查找下一个匹配项
                    Set fnd = .Columns("A").FindNext(after:=fnd)

                ' 循环直到回到第一个匹配项
                Loop Until fnd.Address = addr
            End If
        Next a

    End With

    ' 复制到目标工作表sheet19
    With Worksheets("sheet19")
        If Not cpy Is Nothing Then
            cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            MsgBox "所有匹配行的下一行已复制完成。"
        Else
            MsgBox "未找到符合条件的行，或匹配行均为工作表最后一行。"
        End If
    End With

    Exit Sub

Err_Execute:
    Debug.Print Now & " " & Err.Number & " - " & Err.Description
    MsgBox "执行出错：" & Err.Description
End Sub

关键改动说明 #

• 核心修改：将原代码中选中fnd.EntireRow（匹配行）改为fnd.Offset(1).EntireRow（匹配行的下一行），覆盖初始化和合并区域的所有操作。
• 边界检查：增加If fnd.Row < .Rows.Count Then判断，避免匹配行是工作表最后一行时，尝试复制不存在的下一行导致错误。
• 空区域处理：复制前检查cpy是否为空，避免无匹配项时执行复制操作报错，并给出对应提示。

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