Question

I have some code that loops through a series of sheets in a workbook and tries to find a match to a value in another sheet.

Private Sub MatchData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)
Dim wksFinalized As Worksheet
Dim lCount As Long
Dim lFinMaxRow As Long
Dim DataRange As Variant
Dim SearchRange As Variant
Dim FoundRange As Range

Application.Calculation = xlCalculationManual

With NewMIARep

    DataRange = .Range("J2:K" & MaxRow)
    SearchRange = .Range("A2:A" & MaxRow)

    For Each wksFinalized In wkbFinalized.Sheets
        lFinMaxRow = GetMaxRow(wksFinalized)
        If lFinMaxRow > 1 Then
            For lCount = 1 To MaxRow - 1
                If Len(DataRange(lCount, 1)) = 0 And Len(DataRange(lCount, 2)) = 0 Then
                    Set FoundRange = wksFinalized.Range("A2:A" & lFinMaxRow).Find(What:=SearchRange(lCount, 1), _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)
                    If Not FoundRange Is Nothing Then
                        DataRange(lCount, 1) = FoundRange.Offset(ColumnOffset:=12).Value
                        DataRange(lCount, 2) = FoundRange.Offset(ColumnOffset:=2).Value
                        Set FoundRange = Nothing
                    End If
                End If
            Next lCount
        End If
    Next wksFinalized

.Range("J2:K" & MaxRow).Value = DataRange
.Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"

End With

Application.Calculation = xlCalculationAutomatic

As this goes through every sheet in wkbFinalized, and each sheet has 30,000-60,000 or so records, and I loop another 5,000-6,000 times within that loop for each of the items I want to search for, this tends to slow down quite a bit (not the fastest machine in the world, but I have no choice in the matter).

I know I can’t do this specifically, but I’m looking for a function that will work like
wkbFinalized.Find(...)
vs.
wkbFinalized.Sheets(n).Find(...).

Does such a function exist?

OR Is there a way to somehow preload all the data from all sheets into one range before searching, so that the internal loop only runs once? (and would this be any more or less efficient?)

Answer 1

This was easier than I thought. I just needed to find the right muse, I suppose. This doesn’t directly address searching when duplicates exist, but for my case, each search term was unique across all worksheets, so this did work.

Private Sub MatchData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)

Dim wksFinalized As Worksheet
Dim lCount As Long
Dim lFinMaxRow As Long
Dim DataRange As Variant
Dim SearchRange As Variant
Dim FoundRange As Range
Dim FindRange As Range
Dim colBill As New Collection
Dim colDate As New Collection

    Application.Calculation = xlCalculationManual

    With NewMIARep

        DataRange = .Range("J2:K" & MaxRow)
        SearchRange = .Range("A2:A" & MaxRow)

        For Each wksFinalized In wkbFinalized.Sheets
            lFinMaxRow = GetMaxRow(wksFinalized)
            If lFinMaxRow > 1 Then

                Set FindRange = wksFinalized.Range("A2:M" & lFinMaxRow)

                For lCount = 1 To lFinMaxRow - 1
                    ' Keep one collection per item to pull from in search.
                    ' This can be expanded to one collection for each column you want to search.
                    ' I chose to use the direct value, but I suppose you could also grab the column(/number) or row number, 
                    ' or anything else about the cell found to use as a reference instead.
                    ' Do this for all sheets BEFORE doing the lookups to avoid extra looping.
                    If Not InCollection(colBill, FindRange(lCount, 1).value) Then
                        colBill.Add FindRange(lCount, 3).value, FindRange(lCount, 1).value
                        colDate.Add FindRange(lCount, 13).value, FindRange(lCount, 1).value
                    End If

                Next lCount
            End If
        Next wksFinalized


        For lCount = 1 To MaxRow - 1
            If Len(DataRange(lCount, 1)) = 0 And Len(DataRange(lCount, 2)) = 0 Then
                If InCollection(colBill, CStr(SearchRange(lCount, 1))) Then
                    ' For each search term, if we have a match in our previously created collections,
                    ' then it exists somewhere in the source workbook, but we don't care on which sheet it resides.
                    ' Simply pull the value from each collection that matches the key of the search term.
                    DataRange(lCount, 1) = colDate.item(CStr(SearchRange(lCount, 1)))
                    DataRange(lCount, 2) = colBill.item(CStr(SearchRange(lCount, 1)))
                End If
            End If
        Next lCount

        .Range("J2:K" & MaxRow).value = DataRange
        .Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"

    End With

    Application.Calculation = xlCalculationAutomatic

End Sub

'The InCollection function was pulled from some other source online. 
'It is not my own creation.

Public Function InCollection(ColToCheck As Collection, KeyToCheck As String) As Boolean

Dim vTemp As Variant
Dim errNumber As Long

    InCollection = False

    Set vTemp = Nothing
    Err.Clear

    On Error Resume Next
    vTemp = ColToCheck.item(KeyToCheck)

    InCollection = (CLng(Err.Number) <> 5)
    On Error GoTo 0    '5 is not in, 0 and 438 represent incollection

    Err.Clear

    Set vTemp = Nothing

End Function

This runs in much less time than the original version.

Here’s the same as above, but using Scripting.Dictionary objects instead, eliminating the need for the second function (InCollection):

Private Sub MatchData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)

Dim wksFinalized As Worksheet
Dim lCount As Long
Dim lFinMaxRow As Long
Dim DataRange As Variant
Dim SearchRange As Variant
Dim FoundRange As Range
Dim FindRange As Range
Dim dictBill As Object
Dim dictDate As Object


    Application.Calculation = xlCalculationManual

    Set dictBill = CreateObject("Scripting.Dictionary")
    Set dictDate = CreateObject("Scripting.Dictionary")

    With NewMIARep

        DataRange = .Range("J2:K" & MaxRow)
        SearchRange = .Range("A2:A" & MaxRow)

        For Each wksFinalized In wkbFinalized.Sheets
            lFinMaxRow = GetMaxRow(wksFinalized)
            If lFinMaxRow > 1 Then

                Set FindRange = wksFinalized.Range("A2:M" & lFinMaxRow)

                For lCount = 1 To lFinMaxRow - 1
                    ' Keep one collection per item to pull from in search.
                    ' This can be expanded to one collection for each column you want to search.
                    ' I chose to use the direct value, but I suppose you could also grab the column(/number) or row number,
                    ' or anything else about the cell found to use as a reference instead.
                    ' Do this for all sheets BEFORE doing the lookups to avoid extra looping.
                    If Not dictBill.Exists(FindRange(lCount, 1).Value) Then
                        dictBill.Add FindRange(lCount, 1).Value, FindRange(lCount, 3).Value
                        dictDate.Add FindRange(lCount, 1).Value, FindRange(lCount, 13).Value
                    End If

                Next lCount
            End If
        Next wksFinalized


        For lCount = 1 To MaxRow - 1
            If Len(DataRange(lCount, 1)) = 0 And Len(DataRange(lCount, 2)) = 0 Then
                If Not dictBill.Exists(CStr(SearchRange(lCount, 1))) Then
                    ' For each search term, if we have a match in our previously created collections,
                    ' then it exists somewhere in the source workbook, but we don't care on which sheet it resides.
                    ' Simply pull the value from each collection that matches the key of the search term.
                    DataRange(lCount, 1) = dictDate.Item(CStr(SearchRange(lCount, 1)))
                    DataRange(lCount, 2) = dictBill.Item(CStr(SearchRange(lCount, 1)))
                End If
            End If
        Next lCount

        .Range("J2:K" & MaxRow).Value = DataRange
        .Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"

    End With

    Application.Calculation = xlCalculationAutomatic

End Sub