VBA - search for a specific word in the column and copy the cell below on a different sheet

advertisements

I need a bit help with a task below:

I have source data -

, which are not aligned to table. I would need to find a text (header - e.g. Account) and copy two whole lines, which are below's the searched cell (Account) and paste them on different Sheet. Then search down and do again until the page with data will be ended and data should be pasted chronologically as it is reached.

The cell with word "Account" will be always in the column A, but number of rows will be different. It should also loop for exact word "Account", because in the column can be cells which contain e.g. "Payer account".

I have this code so far and I've stucked a bit, since it 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

Could you help me with it, please?

Thanks much!


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