VBA: использовать словарь вместо функции vlookup

Question

Я использую функцию vlookup в своем коде VBA, но она занимает слишком много времени для запуска, когда у меня более 100 000 строк данных:

Sub getType()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim Row As Long
Dim Clm As Long


Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table1 = Sheet2.Range("A2:A" & LastRow1)
Set ws = Sheets("CRI")
    LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table2 = CRI.Range("A2:D" & LastRow2)
Row = Sheet2.Range("J2").Row
Clm = Sheet2.Range("J2").Column

For Each cl In Table1
  Sheet2.Cells(Row, Clm).Value = Application.WorksheetFunction.VLookup(cl, Table2, 4, False)
  Row = Row + 1
Next cl
Calculate

Читая некоторые темы здесь, я проверил, что можно ускорить использование словаря, но я не понял концепции правильно, чтобы реализовать решение в моем коде.

Кроме того, в таблице 2 нет повторяющихся данных, но таблица 1 содержит повторяющиеся значения.

Может ли кто-нибудь помочь мне преобразовать vlookup в словарь и, если возможно, сослаться на некоторые видеоуроки, чтобы я мог изучить концепцию?

Answer 1

Вот некоторый тестовый код, чтобы показать, почему я предложил запустить вашу VLOOKUP для диапазона на рабочем листе, а не для массива (что вы получили, не используя Set Table = ...)

Формулы рабочих листов, такие как vlookup, оптимизированы для рабочих таблиц, а не для массивов.

Поиск по листу примерно в 130 раз быстрее, чем поиск по массиву.

Sub Tester()

    Const NUMR As Long = 100000
    Dim r As Long, arr, t, m, rng

    'Fill some dummy data if not already there
    If Sheet1.Range("A1") = "" Then
        For r = 1 To NUMR
            Sheet1.Cells(r, 1).Resize(1, 4).Value = _
                     Array(CLng(Rnd * NUMR), "A", "B", r)
        Next r
    End If

    Set rng = Sheet1.Range("A1").CurrentRegion
    arr = rng.Value

    'Vlookup against array
    t = Timer
    For r = 1 To 100
        m = Application.VLookup(r, arr, 4, False)
    Next r
    Debug.Print Timer - t '>> 10.28

    'Vlookup against worksheet Range
    t = Timer
    For r = 1 To 100
        m = Application.VLookup(r, rng, 4, False)
    Next r
    Debug.Print Timer - t '>> 0.078

End Sub

Answer 2

Это хорошее объяснение использования словаря:

https://excelmacromastery.com/vba-dictionary/

Не забудьте добавить «Microsoft Scripting Runtime» в качестве ссылки на ваш проект.

Я провел несколько тестов, чтобы проверить производительность. Для миллиона строк данных у меня были следующие результаты:

VLookup: 27,93 секунд

Словарь: 20,83 секунды

Словарь и массив: 2,32 секунды

Рассматривали ли вы использование словаря и массива для хранения значений перед записью их на лист? Эта ссылка предоставит вам полезную информацию:

https://excelmacromastery.com/excel-vba-array/#How_To_Make_Your_Macros_Run_at_Super_Speed

Примите во внимание следующее (я попытался оставить как можно больше вашего исходного кода):

Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error GoTo Handler

Dim ws As Worksheet

Dim LastRow1 As Long
Dim LastRow2 As Long

Dim i As Long

Dim Table1 As Range
Dim Table2 As Range
Dim cl As Range
Dim r As Range
Dim targetRange As Range

Dim valuesArray As Variant

Dim dict As New Scripting.Dictionary

Dim timeStart As Double
Dim timeInterval As Double

'start a timer to measure performance
timeStart = Timer()

'Get the column of data to search through
Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table1 = ws.Range("A2:A" & LastRow1)

'Get the table of values to search for
Set ws = Sheets("CRI")
LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table2 = ws.Range("A2:D" & LastRow2)

'Add the contents of the table you are searching to the dictionary:
'For each row in the table
For Each r In Table2.Rows

    'Add the key and associated value for that key
    dict.Add r.Cells(1, 1).Value, r.Cells(1, 4).Value

Next r

'Dimension an array to fit all of your values
ReDim valuesArray(1 To LastRow1, 1 To 1)

'Use i to allocate the data to the array
i = 1

For Each cl In Table1

    'Set the value of the array element to the value returned by the dictionary
    valuesArray(i, 1) = dict(cl.Value)
    i = i + 1

Next cl

'Set a target range to put your values in and make it the right size to fit your array
Set targetRange = Worksheets("Target").Range("J2").Resize(UBound(valuesArray, 1) - 1)

'Put the array in the target range
targetRange = valuesArray

'Check how much time it took
timeInterval = Timer() - timeStart
Debug.Print timeInterval

Application.ScreenUpdating = True

Надеюсь, это поможет.