Excel VBA：複数の配列間でインデックス（Match（））を複製する

Question

現在、私は毎月手動で準備しているレポートを自動化しようとしていますが、効率的に実行するにはいくつか問題があります。基本的には、報告書は、4つの入力があります。

1. を今月YTDは[87K行×8つのcols] &貯蓄レポート（部品番号別）[70K行×4つのcolsの]
2. 今月部品番号ルックアップテーブルを過ごし
あなたが見ることができるように（製品番号）&貯蓄レポートをお過ごし[60K行×4つのcolsの]
3. 前月品番ルックアップテーブル[77K行×8つのcols]

前の月YTDこれらはかなり大きな情報テーブルです（確かに最大ではありません）。年末までに、より多くの部品番号をリリースし続けるにつれて、これらのテーブルが大きくなる（おそらく25％）と期待しています。

私の目標は、これらの入力をすべて組み合わせた1つのデータテーブルを取得し、いくつかの列に対して軽い数学的計算を実行することです。ここに私のコードは、これまでのようになります。

'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行をループしています。それはループスルーする潜在的な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

もう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")で行ったように辞書を作成することでこれを避けることができますが、参照を追加して型チェックを行う方が好きです。