Excel VBA：在幾個陣列之間複製索引（匹配（））

我試圖自動化一個我目前每個月都要手動準備的報表，但是我有一些問題需要高效運行。基本上，報告有4個輸入：Excel VBA：在幾個陣列之間複製索引（匹配（））

當前月YTD花&儲蓄報告（部件編號）[70K行×4個COLS]
當前月零件編號查找表[87K行×8個COLS]
上月至今花&儲蓄報告（部件編號）[60K行×4周的cols]
上個月型號查找表[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))

工作？我將如何指定我想要查看的輸入數組中的列？任何提示讓這件事情以更合理的速度進行？

在此先感謝您的幫助！

來源

2016-08-04 Tom Winchester

快速注 - 陣列從一個工作表區域回升將基於一個總是，這樣你就可以簡化您的numRows行/數numCols任務只是' UBound（array，[dimension]）' –

每個工作表上的數據是否在A1上開始？ – 2016-08-04 17:51:50

如果你想避免循環，那麼你可以在每個數組中創建基於字典的查找：這將快得多。 –

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

來源

2016-08-04 21:06:34 michael

這裏展示的一般方法一個簡單的例子：

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

來源

2016-08-04 18:08:41

感謝這個例子 - 我會考慮適應這一點，並回到你身邊。再次感謝Tim。 –

所以我拿着你的代碼，並以我能理解的方式寫回來 - 它的工作幾乎完美無瑕。整個運行時間現在約爲60秒，比我想象的要好得多。我有一個小問題。回想一下，我在字典中爲我的鍵使用連接字符串。一些連接字符串是字母數字，其餘的只是數字。當我在字典中查找它們時，似乎所有隻有數字的連接字符串都沒有找到。我試着格式化所有列A的數字，但是這是行不通的。有什麼想法嗎？ –

僅供參考：通過確保我在將密鑰添加到字典時使用Cstr（），我能夠解決此問題。 –

這裏就是我提出的一個樣本，只是第一個輸入表。您可以將此模式擴展到查找表的其餘部分。

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")所做的那樣，但我更傾向於添加引用並獲得更好的類型檢查。

來源

2016-08-04 18:10:01 Mikegrann

謝謝，邁克。如果遇到問題，我會試試這個，讓你知道。 –

Excel VBA：在幾個陣列之間複製索引（匹配（））

回答

相關問題