Thread: For..Next loop and FindNext problem

Hi, Excel community experts!

I am trying to find a list of values from column 1 in Sheets("Find") in all the other sheets. For each value that is found in column "I" in each of the sheets, I want to copy specific cell values in that row to Sheets"Find" in column B through to column U.

My code doesn't loop through all the sheets to search from row 9 to last used row. What is wrong with the code? Appreciate any help on my problem and thanks a bunch.

Code:

Option Explicit

Sub FindAndCopyFromSheetsFound()

Dim lastcol As Integer, lastrw As Long, lastrow As Long, lastcolumn As Integer, i As Long, j As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rSearch As Range
Dim rFound As Range, rFoundCol As Integer, rFoundRow As Long, FirstAddress As String

Sheets("Find").Activate
Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(1234, 25)).ClearContents
FindSht.Range(Cells(2, 2), Cells(1234, 25)).ClearFormats
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
  SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.Cells(FindSht.Rows.Count, "A").End(xlUp).Row
                
For Each ws In Worksheets
    lastrow = ws.Cells.Find(what:="*", after:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
        For i = 2 To lastrw
        vFind = FindSht.Cells(i, 1)
        
        Application.ScreenUpdating = False
        'On Error Resume Next
        On Error GoTo ErrHandlr
        
        If ws.Name <> FindSht.Name Then

            With ws
            Set rSearch = Range("I9:I" & Cells(65536, 9).End(xlUp).Row)

            'Search for the first occurrence of the item
            Set rFound = rSearch.Find(what:=vFind, LookIn:=xlValues, lookat:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            
                j = 2
                If Not rFound Is Nothing Then
            
                    Do
                        FirstAddress = rFound.Address
                        rFoundCol = rFound.Column
                        rFoundRow = rFound.Row
                
                        ws.Range("F" & rFoundRow & ":R" & rFoundRow).Copy FindSht.Cells(j, "H")
                        Debug.Print "rFound & Qty = " & rFound.Value & " Qty:" & rFound.Offset(, 3).Value
                        FindSht.Cells(j, "B").Value = ws.Name
                        ws.Range("A" & rFound.Row).End(xlUp).Resize(1, 5).Copy FindSht.Cells(j, "C")
                        ws.Range("S" & rFound.Row).End(xlUp).Copy FindSht.Cells(j, "U")
                    
                        j = j + 1
                
                        'Search for the next cell with a matching value
                        Set rFound = rSearch.FindNext(rFound)

                    Loop While Not rFound Is Nothing And rFound.Address <> FirstAddress
                End If
            End With
        End If
        
        Next i

ErrHandlr: If Err.Number = 1004 Then
    Exit For
    End If
Next ws

FindSht.Range("A2").Select
Application.ScreenUpdating = True

Set rFound = Nothing
Set rSearch = Nothing
Set FindSht = Nothing

End Sub