我正在尝试自动生成我目前每月手动准备的报告，但我遇到了一些问题，使其有效运行。基本上，该报告有4个输入：
正如您所看到的，这些是相当大的信息表（当然不是最大的）。到今年年底，随着我们继续发布更多零件编号，我预计这些表格会变得更大（可能是25％）。
我的目标是获得一个结合了所有这些输入的数据表，并为几列做一些简单的数学计算。这是我的代码到目前为止的样子：
'Store data from 4 data worksheets into arrays
Dim arrPrevDMCRLookup As Variant
Dim lngFirstPDLRow As Long 'PDL = Previous DMCR Lookup
Dim lngLastPDLRow As Long
Dim lngNumPDLRows As Long
Dim lngNumPDLCols As Long
lngFirstPDLRow = 2 'Does not store header row
lngLastPDLRow = wsPreviousLookupData.UsedRange.Rows.Count
arrPrevDMCRLookup = wsPreviousLookupData.Range("A" & lngFirstPDLRow & ":H" & lngLastPDLRow)
lngNumPDLRows = UBound(arrPrevDMCRLookup, 1) - LBound(arrPrevDMCRLookup, 1) + 1
lngNumPDLCols = UBound(arrPrevDMCRLookup, 2) - LBound(arrPrevDMCRLookup, 2) + 1
Dim arrPrevDMCRPivot As Variant
Dim lngFirstPDPRow As Long 'PDP = Previous DMCR Pivot
Dim lngLastPDPRow As Long
Dim lngNumPDPRows As Long
Dim lngNumPDPCols As Long
lngFirstPDPRow = 5 'Does not store header row
lngLastPDPRow = wsPreviousPivotSheet.UsedRange.Rows.Count
arrPrevDMCRPivot = wsPreviousPivotSheet.Range("A" & lngFirstPDPRow & ":D" & lngLastPDPRow)
lngNumPDPRows = UBound(arrPrevDMCRPivot, 1) - LBound(arrPrevDMCRPivot, 1) + 1
lngNumPDPCols = UBound(arrPrevDMCRPivot, 2) - LBound(arrPrevDMCRPivot, 2) + 1
Dim arrCurrDMCRLookup As Variant
Dim lngFirstCDLRow As Long 'CDL = Current DMCR Lookup
Dim lngLastCDLRow As Long
Dim lngNumCDLRows As Long
Dim lngNumCDLCols As Long
lngFirstCDLRow = 2 'Does not store header row
lngLastCDLRow = wsCurrentLookupData.UsedRange.Rows.Count
arrCurrDMCRLookup = wsCurrentLookupData.Range("A" & lngFirstCDLRow & ":H" & lngLastCDLRow)
lngNumCDLRows = UBound(arrCurrDMCRLookup, 1) - LBound(arrCurrDMCRLookup, 1) + 1
lngNumCDLCols = UBound(arrCurrDMCRLookup, 2) - LBound(arrCurrDMCRLookup, 2) + 1
Dim arrCurrDMCRPivot As Variant
Dim lngFirstCDPRow As Long 'CDP = Current DMCR Pivot
Dim lngLastCDPRow As Long
Dim lngNumCDPRows As Long
Dim lngNumCDPCols As Long
lngFirstCDPRow = 5 'Does not store header row
lngLastCDPRow = wsCurrentPivotSheet.UsedRange.Rows.Count
arrCurrDMCRPivot = wsCurrentPivotSheet.Range("A" & lngFirstCDPRow & ":D" & lngLastCDPRow)
lngNumCDPRows = UBound(arrCurrDMCRPivot, 1) - LBound(arrCurrDMCRPivot, 1) + 1
lngNumCDPCols = UBound(arrCurrDMCRPivot, 2) - LBound(arrCurrDMCRPivot, 2) + 1
'Create array for output data
Dim arrData As Variant
ReDim arrData(1 To lngNumCDPRows, 1 To 21) 'arrData needs to have the same number of rows as arrCurrDMCRPivot and 21 columns
'Fill arrData
Dim i As Long 'Loop variable
Dim j As Long 'Loop variable
For i = 1 To lngNumCDPRows
'Update status bar
Call UpdateStatusBar(1, lngNumCDPRows, i, "Combining reports...")
'Grab data from arrCurrDMCRPivot
arrData(i, 1) = arrCurrDMCRPivot(i, 1) 'Concatenate string
arrData(i, 9) = arrCurrDMCRPivot(i, 2) 'Current Engineering Manager
arrData(i, 10) = arrCurrDMCRPivot(i, 3) 'Current YTD USD Spend
arrData(i, 11) = arrCurrDMCRPivot(i, 4) 'Current YTD USD Savings
'Lookup data from arrCurrDMCRLookup
For j = 1 To lngNumCDLRows
If arrData(i, 1) = arrCurrDMCRLookup(j, 1) Then 'Concatenate strings match
arrData(i, 2) = arrCurrDMCRLookup(j, 2) 'Part number
arrData(i, 3) = arrCurrDMCRLookup(j, 3) 'Part name
arrData(i, 4) = arrCurrDMCRLookup(j, 4) 'Supplier Code
arrData(i, 5) = arrCurrDMCRLookup(j, 5) 'Supplier Name
arrData(i, 6) = arrCurrDMCRLookup(j, 6) 'DMCR Comp Grp
arrData(i, 7) = arrCurrDMCRLookup(j, 7) 'ACSD Org
arrData(i, 12) = arrCurrDMCRLookup(j, 8) 'Current DMCR: Prior Year Average Cost
Exit For 'Stop looking when a match was found
End If
Next j
'Lookup data from arrPrevDMCRPivot
For j = 1 To lngNumPDPRows
If arrData(i, 1) = arrPrevDMCRPivot(j, 1) Then 'Concatenate strings match
arrData(i, 13) = arrPrevDMCRPivot(j, 2) 'Previous Engineering Manager
arrData(i, 14) = arrPrevDMCRPivot(j, 3) 'Previous YTD USD Spend
arrData(i, 15) = arrPrevDMCRPivot(j, 4) 'Previous YTD USD Savings
Exit For 'Stop looking when a match was found
End If
Next j
'Lookup data from arrPrevDMCRLookup
For j = 1 To lngNumPDLRows
If arrData(i, 1) = arrPrevDMCRLookup(j, 1) Then 'Concatenate strings match
arrData(i, 16) = arrPrevDMCRLookup(j, 8) 'Previous DMCR: Prior Year Average Cost
Exit For 'Stop looking when a match was found
End If
Next j
'Calculate remaining fields
Next i
正如您所看到的，我使用嵌套循环在我的数组中复制Index（Match（））的功能。然而 - 这似乎是非常缓慢的！看看我的状态栏更新，我不认为我已经看到它完成了一行！
现在，我在输出数组的EACH ROW中循环遍历3个数组的潜在224k行。这是一个潜在的1570万行循环！必须有更好的方法来做到这一点，对吧？会使用
Application.WorksheetFunction.Index(<column from one of the input arrays>, Application.WorksheetFunction.Match(<concatenate string from output array>,<column from input array containing concatenate strings>,0))
工作？如何从输入数组中指定要查看的列？有什么提示让这件事情以更合理的速度发挥作用？
先谢谢你的帮助!!!
答案 0 :(得分：3)
另一种解决方案是映射Collection中的所有行。它会比Dictionary快至少30％，并且它是VBA原生的。
以下是您的数据示例：
Dim mapCurrDMCRLookup As Collection
Set mapCurrDMCRLookup = MapRows(arrCurrDMCRLookup, Column:=1)
For i = 1 To lngNumCDPRows
'Lookup data from arrCurrDMCRLookup
j = GetRow(mapCurrDMCRLookup, arrData(i, 1))
If j > -1 Then ' if found
arrData(i, 2) = arrCurrDMCRLookup(j, 2) 'Part number
...
End If
Next
Function MapRows(data(), Column As Integer) As Collection
Set MapRows = New Collection
On Error Resume Next
Dim r As Long
For r = LBound(data) To UBound(data)
MapRows.Add r, CStr(data(r, Column))
Next
End Function
Function GetRow(map As Collection, value) As Long
On Error Resume Next
GetRow = -1
GetRow = map(CStr(value))
End Function
答案 1 :(得分：2)
这是一个显示一般方法的简化示例：
Sub Tester()
Dim i As Long, r As Long, v
'main driving array
Dim arrPrevDMCRPivot As Variant
arrPrevDMCRPivot = GetData(wsPreviousPivotSheet)
'array to be joined in....
Dim arrPrevDMCRLookup As Variant, dictPrevDMCRLookup As Object
arrPrevDMCRLookup = GetData(wsPreviousLookupData)
Set dictPrevDMCRLookup = GetDict(arrPrevDMCRLookup, 1)
'other arrays and lookups here....
For i = 1 To UBound(arrPrevDMCRPivot)
v = arrPrevDMCRPivot(i, 1) 'the lookup value
If dictPrevDMCRLookup.exists(v) Then
r = dictPrevDMCRLookup(v) 'r is the matching row in arrPrevDMCRLookup
'use values from arrPrevDMCRLookup "row" r
'.....
End If
'check other arrays/looups
Next i
End Sub
Function GetData(sht As Worksheet)
Dim arr
With sht.Range("A1").CurrentRegion
arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With
End Function
'get a lookup dictionary key=values from column [colNum], value=row
Function GetDict(arr, colNum As Long)
Dim rv As Object, r As Long
Set rv = CreateObject("scripting.dictionary")
For r = 1 To UBound(arr, 1)
If Not rv.exists(arr(r, colNum)) Then rv.Add arr(r, colNum), r
Next r
Set GetDict = rv
End Function
答案 2 :(得分：1)
这是我提出的一个示例，仅针对第一个输入表。您可以将此模式扩展到其余查找表。
Dim DMCRLookupDictionary As New Dictionary
' ...
arrPrevDMCRLookup = wsPreviousLookupData.Range("A" & lngFirstPDLRow & ":H" & lngLastPDLRow)
lngNumPDLRows = UBound(arrPrevDMCRLookup, 1)
lngNumPDLCols = UBound(arrPrevDMCRLookup, 2)
' Build the dictionary mapping lookupKey -> lookupRow
Dim j As Long
For j = 1 To lngNumPDLRows
If Not DMCRLookupDictionary.Exists(arrPrevDMCRLookup(j, 1)) Then
DMCRLookupDictionary.Add(arrPrevDMCRLookup(j, 1), j)
End If
Next j
' ...
For i = 1 To lngNumCDPRows
' ...
If DMCRLookupDictionary.Exists(arrData(i, 1)) Then
j = DMCRLookupDictionary(arrData(i, 1))
arrData(i, 2) = arrCurrDMCRLookup(j, 2)
arrData(i, 3) = arrCurrDMCRLookup(j, 3)
' ...
End If
Next i
请注意，这只会匹配查找表中遇到的第一个值（但是，示例代码也是如此）。小心重复。
还要求您导入脚本运行时以访问Dictionary类。 Tools > References > Microsoft Scripting Runtime您可以通过像Tim对Dim DMCRLookupDictionary As Object: Set DMCRLookupDictionary = CreateObject("Scripting.Dictionary")那样创建词典来避免这种情况，但我更倾向于添加引用并进行更好的类型检查。