検索をDictionary使用にて高速化
このマクロは、「Dictionary（ディクショナリー）のパフォーマンスについて」を参考にしています。ありがとうございます。
シート「A」の番号を、シート「B」から一致する「id」を検索し、一致したら「Price」のデータを、シート「A」の「価格」をその「Price」に変更する例で説明します。
シート「A」は以下。7万行以上あります。
シート「B」は以下。3万行以上あります。
以下が、マクロです。
' 配列
Dim TableA() As Variant ' シート「A」
Dim TableB() As Variant ' シート「B」
Sub サンプルメイン()
Dim sTimer As Single ' 処理時間測定用
sTimer = Timer
Call sheet_to_array(ThisWorkbook.Worksheets("A"), TableA) ' シート「A」を配列に入れる
Call sheet_to_array(ThisWorkbook.Worksheets("B"), TableB) ' シート「B」を配列に入れる
Debug.Print "シート＞配列：" & Timer - sTimer ' 処理時間測定用
Call Dictionary使用sample
Debug.Print "検索完了：" & Timer - sTimer & vbCrLf ' 処理時間測定用
End Sub
Private Sub Dictionary使用sample()
Dim Keyval As String
Dim Itemval As Long
Dim n As Long
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
For n = 2 To UBound(TableB) '参照用の配列を要素数分ループ
Keyval = TableB(n, 2) '③Keyを格納
Itemval = TableB(n, 1) '④Itemを格納
'未登録の場合登録
If Not myDic.Exists(Keyval) Then
myDic.Add Keyval, Itemval
End If
Next n
For n = 2 To UBound(TableA) '検索用配列の要素数分ループ
Keyval = TableA(n, 2)
If myDic.Exists(Keyval) Then
TableA(n, 1) = myDic(Keyval) '検索値のKeyでItemを抽出
End If
Next n
Set myDic = Nothing
End Sub順番に説明します。以下で、シートの値を配列に入れています。高速化の常套手段です。
Call sheet_to_array(ThisWorkbook.Worksheets("A"), TableA) ' シート「A」を配列に入れる
Call sheet_to_array(ThisWorkbook.Worksheets("B"), TableB) ' シート「B」を配列に入れる「Call sheet_to_array」は、以下を参照してください。
以下で、Dictionary（連想配列）を作成しています。
Set myDic = CreateObject("Scripting.Dictionary")
For n = 2 To UBound(TableB) '参照用の配列を要素数分ループ
Keyval = TableB(n, 2) '③Keyを格納
Itemval = TableB(n, 1) '④Itemを格納
'未登録の場合登録
If Not myDic.Exists(Keyval) Then
myDic.Add Keyval, Itemval
End If
Next n以下で検索しています。
For n = 2 To UBound(TableA) '検索用配列の要素数分ループ
Keyval = TableA(n, 2)
If myDic.Exists(Keyval) Then
TableA(n, 1) = myDic(Keyval) '検索値のKeyでItemを抽出
End If
Next nこの中の「TableA(n, 1) = myDic(Keyval) ‘検索値のKeyでItemを抽出」だけで、Dictionary（連想配列）から、一致する「id」を検索して、「Price」を返しています。
マクロを実行した結果、以下の通り、価格が「1」に変更されています。
このマクロの処理時間は、以下の通り、0.3秒程度です。
Follow me!
