Copy next word line from sheet to another sheet-CodePudding

i got code to find all rows that contain specific words then send it to another sheet and it works fine but i faced one issue that i want to copy the next row of found word then paste it in next column in next sheet.

code:

Option Explicit

Sub SearchForString()

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

    On Error GoTo Err_Execute

    'populate the array for the outer loop
    arr = Array("Water", "Fighter", "Demon")

    With Worksheets("Data")

        'outer loop through the array
        For a = LBound(arr) To UBound(arr)
            'locate first instance
            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
               'record address of first find
                addr = fnd.Address
                'seed the cpy range object
                If cpy Is Nothing Then Set cpy = fnd.EntireRow
                Do
                    'build union
                    Set cpy = Union(cpy, fnd.EntireRow)

                    'look for another
                    Set fnd = .Columns("A").FindNext(after:=fnd)

                'keep finding new matches until it loops back to the first
                Loop Until fnd.Address = addr
            End If
        Next a

    End With

    With Worksheets("sheet19")
        'one stop copy & paste operation
        cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
    End With

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
    Debug.Print Now & " " & Err.Number & " - " & Err.Description

End Sub

here is picture example

Example

i tried to use .Copy .Offset(1) but it wouldn't work, so i tried to ask here may someone got a solution.

CodePudding user response：

Instead of finding and pasting the data in one line, break it into two so that you can copy the offset and paste to the offset.

With Worksheets("sheet19")
    Dim dst As Range
    Set dst = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

cpy.Copy Destination:=dst
cpy.Offset(1) Destination:=dst.Offset(0, 1)