Thread: Put Find code in Loop to find all matches

hi guys,

Is there a way to put the below in a loop so that it finds all of the matches, not just a single match then move onto the next Ccell.

At the moment it is finding 'Sarah' (for example) and then copying the line then moving to 'Forum' when in fact there are multiple 'Sarah's, and I wanted all the Sarah's to be copied then for it to look for the next in the list (Forum).

as a side note it would really really be appreciated if you can educate\talk me through the looping code that you come up with as I would love nothing more than learn in all honestly.

Thanks a lot in advance,

FYI: the below code works atm , just not how i would like it.

Code:

'this sub will find all the members in all the groups for your selected application.
Sub findandmake()

Dim Ws1 As Worksheet 'Search
Dim SearchRng As Range
Dim Ws3 As Worksheet 'Approver Members
Dim FindRng3 As Range
Dim Ws4 As Worksheet 'Output

Dim CopyRng As Range 'Set when Found
Dim PasteRng As Range 'keeps the latest row

Set Ws1 = Worksheets("Groups to find")
Set SearchRng = Ws1.Range("A1:A" & Ws1.Cells(Ws1.Cells.Rows.Count, 1).End(xlUp).Row)

Set Ws3 = Worksheets("Approver Members")
Set FindRng3 = Ws3.Range("A3:A" & Ws3.Cells(Ws3.Cells.Rows.Count, 4).End(xlUp).Row)

Set Ws4 = Worksheets("Approver group members")
Set PasteRng = Ws4.Cells(1, 1)

'Clear all
Ws4.Cells.ClearContents


'If Found in Ws2 then copy entire row to Ws4
Set PasteRng = PasteRng.Offset(1, 0) 'One row empty
Ws3.Range("2:2").Copy Destination:=PasteRng
Set PasteRng = PasteRng.Offset(1, 0) 'One row header

For Each Ccell In SearchRng
  Set CopyRng = FindRng3.Find(What:=Ccell, LookAt:=xlWhole)
  If Not CopyRng Is Nothing Then
    CopyRng.EntireRow.Copy Destination:=PasteRng
    Set PasteRng = PasteRng.Offset(1, 0)
    Else
    
  End If
        
Next

I don't think you need a loop to find all the "Sarah" values in column A and copy the rows. You need to turn on the Data > Filter > Autofilter and filter column A by the name "Sarah". Then you can copy all visible rows to the other sheet, turn off the filter and you got them all.

If you attached a sample workbook with this code with a good "sample results" page so we can see the before/after, we can help more accurately.

Maybe like this, Sarah.

The variable sAddr caches the address of the first cell found containing each value. The inner loop iterates until it finds the same cell again. I didn't set up anything to test it with, so it's ... untested.

Code:

Sub FindAndMake()
    Dim wksGrps     As Worksheet    'Search
    Dim wksAppr     As Worksheet    'Approver Members
    Dim wksAGrp     As Worksheet    'Output

    Dim rSrch       As Range
    Dim rLook       As Range
    Dim rFind       As Range        'Set when Found
    Dim rPste       As Range        'keeps the latest row
    Dim cell        As Range
    
    Dim sAddr       As String

    Set wksGrps = Worksheets("Groups to find")
    Set rSrch = Intersect(wksGrps.Columns("A"), wksGrps.UsedRange)

    Set wksAppr = Worksheets("Approver Members")
    Set rLook = wksAppr.Range("A3:A" & wksAppr.Cells(wksAppr.Cells.Rows.Count, "D").End(xlUp).Row)

    Set wksAGrp = Worksheets("Approver group members")
    Set rPste = wksAGrp.Range("A2")

    wksAGrp.Cells.ClearContents

    wksAppr.Rows(2).Copy Destination:=rPste

    For Each cell In rSrch
        Set rFind = rLook.Find(What:=cell.Value, LookAt:=xlWhole)
        
        If Not rFind Is Nothing Then
            sAddr = rFind.Address

            Do
                Set rPste = rPste.Offset(1)
                rFind.EntireRow.Copy Destination:=rPste
                Set rFind = rLook.FindNext(rFind)
            Loop While rFind.Address <> sAddr
        End If
    Next cell
End Sub