VBA: Verwenden einer Find-like-Funktion über alle Arbeitsmappen ohne Schleife

Question

Ich habe einige Code, der eine Reihe von Blättern in einer Arbeitsmappe durchläuft und versucht, eine Übereinstimmung mit einem Wert in einem anderen Blatt zu finden.

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 

Wie dies geht durch jedes Blatt in wkbFinalized, und jedes Blatt hat 30.000-60.000 oder so Aufzeichnungen, und ich Schleife weitere 5.000-6.000 mal innerhalb dieser Schleife für jedes der Elemente, die ich für diese suchen möchten neigt dazu, ziemlich viel langsamer zu werden (nicht die schnellste Maschine der Welt, aber ich habe keine Wahl in der Sache).

Ich weiß, dass ich das gerade nicht tun kann, aber ich bin auf der Suche nach einer Funktion, die wie
wkbFinalized.Find(...)
vs.
wkbFinalized.Sheets(n).Find(...) arbeiten.

Gibt es eine solche Funktion?

ODER Gibt es eine Möglichkeit, alle Daten aus allen Blättern vor der Suche irgendwie in einen Bereich vorzuladen, so dass die interne Schleife nur einmal ausgeführt wird? (und wäre das mehr oder weniger effizient?)

Answer 1

Das war einfacher als ich dachte. Ich musste nur die richtige Muse finden. Dies betrifft nicht direkt die Suche, wenn Duplikate existieren, aber für meinen Fall war jeder Suchbegriff in allen Arbeitsblättern eindeutig, so dass dies funktioniert.

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 

Dies läuft in viel weniger Zeit als die ursprüngliche Version.

Hier ist das gleiche wie oben, aber unter Verwendung von Scripting.Dictionary Objekten statt, wodurch die Notwendigkeit für die zweite Funktion eliminiert (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