Find&Copy only copying 1 instance of match

Hi guys,

Can someone please tell me how to get my below code to not copy 1 match of the inputed item, rather all of them.

At the moment if i enter 'Sarah' only 1 sarah is found when in reality sarah appears many times, though only 1 row is being copied with it.

Thanks in advance,

Sub findandmake()

Dim ws1 As Worksheet 'Search
Dim SearchRng As Range
Dim ws2 As Worksheet 'Physical
Dim FindRng2 As Range
Dim ws3 As Worksheet 'Virtual
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("Servers To Find")
Set SearchRng = ws1.Range("A1:A" & ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row)

Set ws2 = Worksheets("Physical Servers")
Set FindRng2 = ws2.Range("P2:P" & ws2.Cells(ws2.Cells.Rows.Count, 4).End(xlUp).Row)

Set Ws4 = Worksheets("Server Results")
Set PasteRng = Ws4.Cells(1, 1)


'Loop through cells removing excess spaces in CRRng of Croff Ref Data WS
With Sheets("Servers To Find")
        
    For Each cl In SearchRng
        If Len(cl) > Len(WorksheetFunction.Trim(cl)) Then
            cl.Value = WorksheetFunction.Trim(cl)
        End If
    Next cl

End With


'Clear all
Ws4.Cells.ClearContents

'First the Headers
ws2.Range("2:2").Copy Destination:=PasteRng
Set PasteRng = PasteRng.Offset(1, 0)

'If Found in Ws1 then copy entire row to Ws4
For Each Ccell In SearchRng
  Set CopyRng = FindRng2.Find(What:=Ccell, LookAt:=xlPart)
  If Not CopyRng Is Nothing Then
    CopyRng.EntireRow.Copy Destination:=PasteRng
    Set PasteRng = PasteRng.Offset(1, 0)
            End If
Next



Call resizeCol2 'this calls the sub that will resize columns in the Server Results WS.
Sheets("Menu").Select
  MsgBox ("Server CI search complete. See 'Server Results' work sheet")
End Sub

Try this:

Option Explicit

Sub findandmake()

Dim ws1         As Worksheet 'Search
Dim SearchRng   As Range
Dim ws2         As Worksheet 'Physical
Dim FindRng2    As Range
Dim ws3         As Worksheet 'Virtual
Dim FindRng3    As Range
Dim Ws4         As Worksheet 'Output

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

Set ws1 = Worksheets("Servers To Find")
Set SearchRng = ws1.Range("A1:A" & ws1.Cells(ws1.Cells.Rows.Count, "A").End(xlUp).Row)

Set ws2 = Worksheets("Physical Servers")
Set FindRng2 = ws2.Range("P2:P" & ws2.Cells(ws2.Cells.Rows.Count, "D").End(xlUp).Row)

Set Ws4 = Worksheets("Server Results")
Set PasteRng = Ws4.Cells(1, 1)


'Loop through cells removing excess spaces in CRRng of Croff Ref Data WS
With ws1
        
    For Each cl In SearchRng
        If Len(cl) > Len(WorksheetFunction.Trim(cl)) Then
            cl.Value = WorksheetFunction.Trim(cl)
        End If
    Next cl

End With


'Clear all
Ws4.Cells.ClearContents

'First the Headers
ws2.Range("2:2").Copy Destination:=PasteRng
Set PasteRng = PasteRng.Offset(1, 0)

'If Found in Ws1 then copy entire row to Ws4
For Each cl In SearchRng
  Set CopyRng = FindRng2.Find(What:=cl, LookAt:=xlPart)
  
  If Not CopyRng Is Nothing Then
    
    If CopyFirst Is Nothing Then Set CopyFirst = CopyRng
    Do
      CopyRng.EntireRow.Copy Destination:=PasteRng
      Set PasteRng = PasteRng.Offset(1, 0)
      Set CopyRng = FindRng2.FindNext(After:=CopyRng)
    Loop Until CopyRng.Address = CopyFirst.Address
    
  End If
Next cl

Call resizeCol2 'this calls the sub that will resize columns in the Server Results WS.
Sheets("Menu").Select
  MsgBox ("Server CI search complete. See 'Server Results' worksheet")
End Sub

Time to post a sample workbook so we can see this stuff together. Click GO ADVANCED and use the paperclip icon to post up a desensitized copy of your workbook.

what's the password?

Nevermind, I think an AutoFilter is a much faster method. Try this instead:

Option Explicit

Sub FindStrings()
Dim Strings As Range
Dim MyStr   As Range
Dim LR      As Long
Dim wsOUT   As Worksheet
Application.ScreenUpdating = False

Set wsOUT = Sheets("Server Results")
wsOUT.Cells.Clear
Set Strings = Sheets("Servers To Find").Range("A:A").SpecialCells(xlConstants)

With Sheets("Physical Servers")
    .Range("A1").EntireRow.Copy wsOUT.Range("A1")
    .Range("P:P").AutoFilter
    
    For Each MyStr In Strings
        .Range("P:P").AutoFilter Field:=1, Criteria1:="*" & MyStr & "*"
        LR = .Range("P" & .Rows.Count).End(xlUp).Row
        If LR > 1 Then _
            .Range("A2:A" & LR).EntireRow.Copy _
               wsOUT.Range("A" & Rows.Count).End(xlUp).Offset(1)
    Next MyStr
    
    .Range("P:P").AutoFilter
End With

wsOUT.Columns.AutoFit
Set wsOUT = Nothing
Set Strings = Nothing
Application.ScreenUpdating = True
End Sub

When evaluating the SAME column row by row, cell by cell for the same value, it's much faster to simply turn on the Data > Filter > AutoFilter and filter that column by the value you're searching for. Once the AutoFilter is on, non-matching rows are hidden so you can literally just copy the whole range and it will ignore the hidden rows...very cool, and much faster overall.

Play around manually with the AutoFilter so you can see all the various things you can do with it.

Cheers.