Find word in column and copy lines below on different sheet - excel

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

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

Answer 2

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