Excel VBA：在几个阵列之间复制索引（匹配（））

Question

我试图自动化一个我目前每个月都要手动准备的报表，但是我有一些问题需要高效运行。基本上，报告有4个输入：

1. 当前月YTD花&储蓄报告（部件编号）[70K行×4个COLS]
2. 当前月零件编号查找表[87K行×8个COLS]
3. 上月至今花&储蓄报告（部件编号）[60K行×4周的cols]
4. 上个月型号查找表[77K行×8周的cols]

正如你所看到的，这些都是相当大的信息表（当然不是最大的）。到年底，随着我们继续释放更多零件数量，我预计这些表格会增加（也许是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 

因此，大家可以看到，我使用嵌套的循环来（比赛（））在我的阵列复制指数的功能。但是 - 这似乎太慢了！看着我的状态栏更新，我不认为我已经看到它完成了一排！

现在，我循环遍历3个阵列的潜在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)) 

工作？我将如何指定我想要查看的输入数组中的列？任何提示让这件事情以更合理的速度进行？

在此先感谢您的帮助！

Answer 1

另一种解决方案是映射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 

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

这里就是我提出的一个样本，只是第一个输入表。您可以将此模式扩展到查找表的其余部分。

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")所做的那样，但我更倾向于添加引用并获得更好的类型检查。