Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 493
  • Last Modified:

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.
0
DCUnited
Asked:
DCUnited
  • 3
  • 2
  • 2
  • +1
1 Solution
 
kgerbChief EngineerCommented:
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
0
 
kgerbChief EngineerCommented:
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
0
 
Curt LindstromCommented:
Maybe something like this assuming your data is on sheet1 and results to be copied to sheet2
 
Sub find_text()
    Dim lRow As Long
    Dim xlLastRow As Long
    Worksheets("Sheet2").Select
    Cells.Clear
    Worksheets("Sheet1").Select
    xlLastRow = Cells.Find("*", Cells(1), xlFormulas, xlWhole, xlByRows, xlPrevious).Row
    
    For i = 2 To xlLastRow
        If Cells(i, 1) = "Rec House" Then
            For j = i To xlLastRow
                If Cells(j, 1) = "Func Tot" Then
                    lRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    Cells(j, 1).EntireRow.Copy Worksheets("Sheet2").Cells(lRow, 1)
                    Exit For
                End If
            Next
        End If
    Next
End Sub

Open in new window

Curt
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
Arno KosterCommented:
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

0
 
Arno KosterCommented:
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

0
 
Curt LindstromCommented:
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
0
 
kgerbChief EngineerCommented:
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
0
 
DCUnitedAuthor Commented:
Perfect! Thank you!
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 3
  • 2
  • 2
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now