VBA Loop is stopping at the first Found result and misses the other matching results

Question

I've written the following code to Search based on Cell B3 and copy paste the values found in the DataSheet to my SearchSheet. Somehow I'm missing something from my loop in order to search for all Values and copy paste them and then stop, since in my case the loop becomes an infinite one

Currrently this is my code

Sub SearchForWord()


    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim searchSheet As Worksheet
    Set searchSheet = ThisWorkbook.Sheets("Search")
    Dim sws As Worksheet: Set sws = wb.Sheets("Outillages")
    Dim sCols() As Variant: sCols = Array("BC", "BD", "BN", "BO")
    Dim dCols() As Variant: dCols = Array("B", "C", "D", "E")
    Dim SearchValue As Variant
    Dim foundCell As Range
    Dim i As Long
    
        Dim sRow As Long: sRow = 2
        Dim dRow As Long: dRow = 6
        Dim scell As Range, dcell As Range
        
    SearchValue = ActiveSheet.Range("B3").Value
    
    If Len(SearchValue) > 0 Then
    Set foundCell = sws.Columns("BC").Find(What:=SearchValue, LookIn:=xlValues, lookat:=xlWhole)
    
    If Not foundCell Is Nothing Then
        Do
            For i = LBound(sCols) To UBound(sCols)
                Set scell = sws.Cells(foundCell.Row, sCols(i))
                Set dcell = searchSheet.Cells(dRow, dCols(i))
                dcell.Value = scell.Value
            Next i
        dRow = dRow + 1
        Set foundCell = sws.Columns("BC").FindNext(foundCell)
                If Not foundCell Is Nothing Then Exit Do
            Loop
            
        
        
        MsgBox "Values copied"
        
        Else
        MsgBox " Value not found"
    End If
    Else
        MsgBox "Please insert a Search Reference Value"
    End If

    End Sub

So for this part if I run with this code the program will stop at the first value instead of going over all values which match my search term.

If I change the this part

                If Not foundCell Is Nothing Then Exit Do

with

                Loop While Not foundCell is Nothing 

Then it looks for all values but it makes the loop infinite

What would be an appropriate way to fix my looping issue such that my code will Look for all values that match and when it finds all of the matching values and no other values to look into it will stop ?

Note: The Excel File that I'm working with has around 270000 lines of data.

Answer 1

Find Multiple Matches in Column Using the Find Method

• When you use the Find method in a range and a value is found, and you continue searching with FindNext or without it, the value will always be found i.e. foundCell will never be Nothing. Therefore, you can use a variable (FirstAddress) to store the address (or the row when searching in a column) of the first found cell so that you can exit the loop when it hits the same cell (or row) again with e.g. Loop While foundCell.Address <> FirstAddress.
• Note that if you plan to modify all the found cells' values until none is left, you will need to use Loop While Not foundCell Is Nothing or the same Loop Until foundCell Is Nothing.

If Len(SearchValue) > 0 Then

    Dim srg As Range: Set srg = sws.Columns("BC") ' **

    Set foundCell = srg.Find( _
        What:=SearchValue, After:=srg.Cells(srg.Cells.Count), _
        LookIn:=xlValues, Lookat:=xlWhole) ' **
    
    If Not foundCell Is Nothing Then
        
        Dim FirstAddress As String: FirstAddress = foundCell.Address ' ***
        
        Do
            For i = LBound(sCols) To UBound(sCols)
                Set scell = sws.Cells(foundCell.Row, sCols(i))
                Set dcell = searchSheet.Cells(dRow, dCols(i))
                dcell.Value = scell.Value
            Next i
            dRow = dRow + 1
            Set foundCell = srg.FindNext(foundCell) ' **
        Loop While foundCell.Address <> FirstAddress ' ***
            
        MsgBox "Values copied", vbInformation
    
    Else
        MsgBox "No value not found", vbExclamation
    End If
Else
    MsgBox "Please insert a Search Reference Value.", vbExclamation
End If