asked on

Find text, find next text copy row to another sheet and loop through worksheet

I need to find a cell in column A that has the text "Rec House" then find another cell with text "Func Tot" also in column A. I need to then copy that row (Func Tot) to another spreadsheet in same workbook. The reason I am going this way is Func Tot can appear 20 times and Rec House can appear 5 times. I need to be able to copy all 5 Func Tot rows for Rec House to another spreadsheet.

kgerb

I believe this macro will work. It gives you all the instances of "Func Tot"

Kyle

Sub FindFuncTot()
Dim c As Range, FirstAddress As String

With Worksheets(1).Range("A:A")
    Set c = .Find("Func Tot", Range("A1"), xlValues, xlWhole, xlByRows, xlNext)
    If Not c Is Nothing Then
        FirstAddress = c.Address
        Do
            c.EntireRow.Copy Destination:=Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> FirstAddress
    End If
End With
End Sub

Open in new window

Q-27400055-RevA.xlsm

kgerb

After re-reading your question, do you need to copy the Func Tot row to a different sheet depending on which "Rec House" it's under? If so the code can be modified for that.

Kyle

ASKER CERTIFIED SOLUTION

Curt Lindstrom

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Arno Koster

you could use something like this :

Sub process()
Dim row As Range
Dim dest As Worksheet
Dim dest_row As Integer

    '-- determine destination worksheet
    Set dest = Worksheets("Sheet2")
    
    '-- process all source rows
    For Each row In UsedRange.Rows
        dest_row = dest.UsedRange.row + dest.UsedRange.Rows.Count
        If row.Cells(1) = "Rec House" Then
            'row.Copy dest.Range("A" & dest_row)
            row.Copy
            dest.Paste dest.Rows(dest_row)
        ElseIf row.Cells(1) = "Func Tot" Then
            'row.Copy dest.Range("A" & dest_row)
        End If
    Next row

End Sub

Open in new window

Arno Koster

whoops, old source code on the clipboard, should have been

Sub process()
Dim row As Range
Dim dest As Worksheet
Dim dest_row As Integer

    '-- determine destination worksheet
    Set dest = Worksheets("Blad2")
    
    '-- process all source rows
    For Each row In UsedRange.Rows
        dest_row = dest.UsedRange.row + dest.UsedRange.Rows.Count
        If row.Cells(1) = "Rec House" Then
            row.Copy
            dest.Paste dest.Range("A" & dest_row)
        ElseIf row.Cells(1) = "Func Tot" Then
            row.Copy
            dest.Paste dest.Range("A" & dest_row)
        End If
    Next row

End Sub

Open in new window

Curt Lindstrom

If you want all "Func Tot" rows under each "Rec House" remove the Exit For.

You should also declare
Dim i as long, j as long

Curt

kgerb

DCUnited,
This sub will put the "Func Tot" rows into the workseet you specify for each instance of "Rec House". Change "House1", "House2", etc to the names of your worksheets. See example file for how it works.

Kyle

Sub FindFuncTot2()
Dim rng As Range, rngLast As Range
Dim cHouse As Range, sHouse As String, SheetNames() As String
Dim i As Long

ReDim SheetNames(5)
SheetNames(1) = "House1"
SheetNames(2) = "House2"
SheetNames(3) = "House3"
SheetNames(4) = "House4"
SheetNames(5) = "House5"

i = UBound(SheetNames)

With Worksheets("Sheet1")
    With .Range("A:A")
        Set rngLast = .Cells(Rows.Count, 1).End(xlUp)
        Set cHouse = .Find("Rec House", .Cells(Rows.Count, 1).End(xlUp), xlValues, xlWhole, xlByRows, xlPrevious)
        If Not cHouse Is Nothing Then
            sHouse = cHouse.Address
            Do
                For Each rng In .Range(rngLast, cHouse)
                    If rng = "Func Tot" Then
                        rng.EntireRow.Copy Sheets(SheetNames(i)).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                    End If
                Next rng
                i = i - 1
                Set rngLast = cHouse
                Set cHouse = .FindPrevious(cHouse)
            Loop While Not cHouse Is Nothing And cHouse.Address <> sHouse
        End If
    End With
End With
End Sub

Open in new window

Q-27400055-RevB.xlsm

DCUnited

ASKER

Perfect! Thank you!