How to speed up code to search many sheets

Question

I have active sheet open (Sheet1). I want to pick a value from C column then go through each workbook and within each workbook there are many sheets. If that value (value from C column of active sheet) matches anywhere in that workbook in any sheet then update in active sheet R column saying found otherwise no update.

Sheet1 has 95000 rows.
book3.xlsx has many sheets which totals 34000 rows.
book4.xlsx too has many rows which totals 24000 rows.
Takes around 4 hours to complete.

Option Explicit
Sub Found()
Dim NumberOfValues1, NumberOfValues2, NumberOfValues3 As Integer
Dim i, n, o As Long
Dim wb1, wb2 As Workbook
Dim wbsb1, worksheet1, worksheet2 As Worksheet
Dim newExcel As Excel.Application
Set newExcel = CreateObject("Excel.Application")
Dim value1, value2, value3 As String
    
Set wb1 = Workbooks.Open("C:\commvault2\book3.xlsx")
Set wb2 = Workbooks.Open("C:\commvault2\book4.xlsx")
Application.ScreenUpdating = FALSE 
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
   
NumberOfValues1 = ThisWorkbook.Sheets("Sheet1").Range("A2").End(xlDown).Row
Set wbsb1 = ThisWorkbook.Sheets("Sheet1")

For i = 2 To NumberOfValues1
    value1 = wbsb1.Range("C" & i).Value
    For Each worksheet1 In wb1.Worksheets
        NumberOfValues2 = worksheet1.Range("A1").End(xlDown).Row
        For n = 1 To NumberOfValues2
            value2 = worksheet1.Cells(n, 1)
            If value1 = value2 Then
                wbsb1.Range("R" & i).Value = "Found"
            End If
        Next
    Next
            
    For Each worksheet2 In wb2.Worksheets
        NumberOfValues3 = worksheet2.Range("A1").End(xlDown).Row
        For o = 1 To NumberOfValues3
            value3 = worksheet2.Cells(o, 1)
            If value1 = value3 Then
                wbsb1.Range("R" & i).Value = "Found"
            End If
        Next
    Next
Next 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

wb1.Close
wb2.Close
newExcel.Quit
Set newExcel = Nothing
End Sub

Answer 1

Check Matches

Option Explicit

Sub CheckMatches()
    
    ' Source
    Dim sFolderPath As String: sFolderPath = "C:\commvault2\"
    Const sFileNamesList As String = "Book3.xlsx,Book4.xlsx" ' no spaces!
    Const slCol As String = "A" ' Lookup Column
    Const sfRow As Long = 1 ' suspicious, possibly 2
    ' Destination
    Const dwsName As String = "Sheet1"
    Const dlCol As String = "C" ' Lookup Column
    Const dvCol As String = "R" ' Value Column
    Const dfRow As Long = 2
    Const dvString As String = "Found"
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
    
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
    If dlRow < dfRow Then Exit Sub ' no data in column
    Dim drCount As Long: drCount = dlRow - dfRow + 1 ' Rows Count
    Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)
    
    Dim Data As Variant ' Destination Lookup and Value Array
    If drCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data = dlrg.Value
    Else
        Data = dlrg.Value
    End If
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim dKey As Variant
    Dim dr As Long
    For dr = 1 To drCount
        dKey = Data(dr, 1)
        If Not IsError(dKey) Then
            If Len(dKey) > 0 Then
                If Not dict.Exists(dKey) Then
                    Set dict(dKey) = New Collection ' to cover for duplicates
                End If
                dict(dKey).Add dr ' array row numbers
            End If
        End If
    Next dr
    If dict.Count = 0 Then Exit Sub ' only error values or blanks
    
    ReDim Data(1 To drCount, 1 To 1) ' clear destination array
    
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    Dim sFileNames() As String: sFileNames = Split(sFileNamesList, ",")
    Dim nUpper As String: nUpper = UBound(sFileNames)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim slrg As Range ' Lookup (Column) Range
    Dim slRow As Long ' Last Row
    Dim srCount As Long ' Rows Count
    Dim sFilePath As String ' File Path
    Dim cItem As Variant ' Collection Item
    Dim n As Long
    Dim FoundAll As Boolean ' No More Dictionary Keys Flag
    
    For n = 0 To nUpper ' loop through workbook names
        sFilePath = sFolderPath & sFileNames(n)
        If Len(Dir(sFilePath)) > 0 Then ' file exists
            Set swb = Workbooks.Open(sFilePath)
            For Each sws In swb.Worksheets
                slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
                If slRow >= sfRow Then
                    srCount = slRow - sfRow + 1
                    Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
                    For Each dKey In dict.Keys ' loop through the dict. keys
                        If IsNumeric(Application.Match(dKey, slrg, 0)) Then
                            ' Loop through each item (row) of the collection
                            For Each cItem In dict(dKey)
                                Data(cItem, 1) = dvString
                            Next cItem
                            dict.Remove dKey
                            If dict.Count = 0 Then
                                FoundAll = True
                                Exit For
                            'Else ' there are still elements in the dictionary
                                'Debug.Print Join(dict.Keys, ",")
                            End If
                        'Else ' match not found
                        End If
                    Next dKey
                    If FoundAll Then Exit For
                'Else ' no data in column
                End If
            Next sws
            swb.Close SaveChanges:=False
        'Else ' file not found
        End If
        If FoundAll Then Exit For
    Next n
          
    ' Write to destination value range ('dvrg').
    Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol)
    dvrg.Value = Data
    
    Dim msgString As String: msgString = "Matches checked."
    If dict.Count > 0 Then
        msgString = msgString & vbLf & vbLf & _
            "Could not find the following items:" & vbLf & Join(dict.Keys, vbLf)
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox msgString, vbInformation

End Sub

Answer 2

Using Match():

Sub Found()

    Dim wb As Workbook, c As Range, wbsb1 As Worksheet, ws As Worksheet
    Dim colWB As New Collection, i As Long, v, m
    
    'add workbooks to be searched to the Collection
    colWB.Add Workbooks.Open("C:\commvault2\book3.xlsx")
    colWB.Add Workbooks.Open("C:\commvault2\book4.xlsx")
    '...can add more wb here...
    
    Set wbsb1 = ThisWorkbook.Sheets("Sheet1")
    
    For Each c In wbsb1.Range("C2:C" & wbsb1.Cells(Rows.Count, "C").End(xlUp).Row).Cells
        v = Trim(c.Value)
        If Len(v) > 0 Then
            For Each wb In colWB                  'loop opened workbooks
                For Each ws In wb.Worksheets      'loop sheets
                    m = Application.Match(v, ws.Columns("A"), 0) 'faster than looping or Find()
                    If Not IsError(m) Then        'if got no match `m` would be an error value
                        c.EntireRow.Columns("R").Value = "Found"
                        GoTo nextValue            'an OK use of Goto...
                    End If
                Next ws
            Next wb
        End If
nextValue:
    Next c
    
    'close all opened workbooks
    For i = colWB.Count To 1 Step -1
        Set wb = colWB(i)
        wb.Close False
    Next
      
End Sub

Answer 3

I am almost sure, the main problem is caused by

NumberOfValues1 = ThisWorkbook.Sheets("Sheet1").Range("A2").End(xlDown).Row

It refers to the last cell/row of the column "A"... Due to this, your code takes all the values in the whole column to perform matching... that means with most empty cells... more than a million empty values... try changing to:

NumberOfValues1 =ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

the same with NumberOfValues2 and NumberOfValues3