這比我想象的要容易。我想，我只需要找到合適的繆斯。當存在重複時，這並不直接解決搜索問題，但對於我而言，每個搜索詞在所有工作表中都是唯一的，所以這確實起作用。
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
這比原始版本的運行時間少得多。
下面是與上面相同，但使用Scripting.Dictionary對象，而不是，省去了第二功能的需要（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
確保您打開/關閉'Application.ScreenUpdating'有更好的表現 – bernie 2012-03-29 15:37:37
@ bernie它是;在原來的調用函數中設置。 :-)這是我的過程中的許多步驟之一。 – Gaffi 2012-03-29 15:41:24
相關提示感謝您注意 – bernie 2012-03-29 16:06:45