Find word in column and copy lines below on differ

Question

I have source data which are not aligned to table.

I want to find text (e.g. Account), copy the two whole lines below the cell with the found text (Account) and paste them on a different Sheet. Then search down and do again until the data ends. Data should be pasted in the order it is reached.

The cell with word "Account" will be always in the column A. The search should be for the exact word "Account", because in the column can be cells which contain e.g. "Payer account".

This code shows me an error msg

"Run-time error 438 - object doesnt support this property or method"

Private Sub Search_n_Copy()

Dim LastRow As Long
Dim rng As Range, C As Range

With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
    Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched

    ' loop through all cells in column A and copy below's cell to sheet "Output_2"
    For Each C In rng
        If C.Value = "Account" Then
            C.Offset(-1, 0).Copy C.Offset.OUTPUT_2(-7, -1) ' use offset to put value in sheet "Output_2", column E
        End If
    Next C
End With

End Sub

Answer 1

The codle would be like this. This code Use variant.

Private Sub Search_n_Copy()

    Dim LastRow As Long
    Dim rng As Range, C As Range
    Dim vR(), n As Long, k As Integer, j As Integer
    Dim Ws As Worksheet

    With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
        .Columns("e").ClearContents
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
        Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched

        ' loop through all cells in column A and copy below's cell to sheet "Output_2"
        For Each C In rng
            If C.Value = "Account" Then
                For j = 1 To 2
                    n = n + 1
                    ReDim Preserve vR(1 To 6, 1 To n)
                    For k = 1 To 6
                        vR(k, n) = C.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
                    Next k
            End If
        Next C
        If n > 0 Then
            Set Ws = Sheets.Add '<~~~  Sheets("your sheet name")
            With Ws
                .Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(vR)
            End With
        End If
    End With

End Sub

Answer 2

This post doesn't point out what the error in your original code is. Ron Rosenfeld has already covered that in the comment.

Here is another faster way (as compared to looping) which uses .Find/.FindNext to achieve what you want. It also doesn't copy the rows in a loop but copies in the end.

Private Sub Search_n_Copy()
    Dim ws As Worksheet
    Dim rngCopy As Range, aCell As Range, bcell As Range
    Dim strSearch As String

    strSearch = "Account"

    Set ws = Worksheets("INPUT_2")

    With ws
        Set aCell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bcell = aCell

            If rngCopy Is Nothing Then
                Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
            Else
                Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
            End If

            Do
                Set aCell = .Columns(1).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bcell.Address Then Exit Do

                    If rngCopy Is Nothing Then
                        Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
                    Else
                        Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
        End If

        '~~> I am pasting to Output sheet. Change as applicable
        If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
    End With
End Sub

Screenshot