Excel VBA：在多個數組之間復制Index（Match（））

Question

我正在嘗試使每個月我目前手動准備的報告自動化，但是在使報告有效運行方面存在一些問題。 基本上，報告有4個輸入：

1. 本月迄今至今的支出和節省報告（按零件號）[70k行x 4列]
2. 當前月份零件號查找表[87k行x 8列]
3. 上個月迄今累計支出和節省報告（按零件號）[60k行x 4列]
4. 上個月零件編號查找表[77k行x 8列]

如您所見，這些是相當大的信息表（肯定不是最大的信息表）。 到年底，隨着我們繼續發布更多的零件號，我希望這些表會更大（也許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（））的功能。 但是，這似乎太慢了！ 查看我的狀態欄更新，我認為我還沒有看到它完整完成！

現在，我正在遍歷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))

工作？ 如何從輸入數組中指定要查看的列？ 有什么技巧可以使這件事以更快的速度進行嗎？

在此先感謝您的幫助！！！

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")創建字典來避免這種情況Dim DMCRLookupDictionary As Object: Set DMCRLookupDictionary = CreateObject("Scripting.Dictionary") ，但是我傾向於添加參考並獲得更好的類型檢查。