Excel VBA：复制几个数组之间的索引（Match（））

我正在尝试自动化每月手动准备的报告，但是我有一些问题需要高效运行。 基本上，报告有4个input：

1. 本月本年度至今花费和储蓄报告（按部件号）[70k行×4列]
2. 本月零件号查找表[87k rows x 8 cols]
3. 上个月年初至今花费和储蓄报告（按部件号）[60k行×4列]
4. 上个月零件号查找表[77k rows x 8 cols]

正如你所看到的，这些信息量相当大（当然不是最大的）。 到今年年底，随着我们继续释放更多的零件数量，我预计这些表格会增长（也许是25％）。

我的目标是获得一个结合了所有这些input的数据表，并为一些列做一些简单的math计算。 以下是我的代码到目前为止：

'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（））在我的数组中的function。 但是 – 这似乎是慢得可笑！ 看着我的状态栏更新，我不认为我已经看到它完成了一排呢！

现在，我正在循环遍历3个arrays的潜在224k行，用于输出数组的每行。 这是一个潜在的1,570万行循环！ 有一个更好的方法来做到这一点，对吧？ 会使用

 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)) 

工作？ 我将如何指定我想要在input数组中的列？ 任何提示，使这件事情以更合理的速度？

在此先感谢您的帮助！！！

Answer 1

另一个解决scheme是映射Collection所有行。 它会比Dictionary快至less30％，并且是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 

Answer 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 

Answer 3

以下是我提出的一个示例，仅供第一个input表使用。 您可以将此模式扩展到查找表的其余部分。

 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您可以通过创build您的字典Tim添加Dim DMCRLookupDictionary As Object: Set DMCRLookupDictionary = CreateObject("Scripting.Dictionary")来避免这种情况，但是我倾向于添加引用并获得更好的types检查。