Нужно сделать Excel VBA vlookup более эффективным

Question

Я перерабатываю некоторые финансовые отчеты для своей организации, чтобы отойти от стороннего программного обеспечения и хочу использовать VBA для помощи в автоматизации. С колледжа не писал VBA, поэтому немного ржавый.

Я получил код для работы, однако он очень неэффективен и работает с 1000 тыс. Записей каждые 30 секунд, что невозможно с несколькими сотнями тысяч записей. Я пробовал несколько разных вариантов, которые вы все опубликовали в разных темах, но, должно быть, что-то упустили.

Не могли бы вы взглянуть?

Большинство потоков, на которые я смотрел, ссылались либо на прямой ввод через одну ячейку, либо на тот же лист, чтобы выполнить поиск. Это один столбец на листе A (расчет резервирования ATB-Calc), а затем поиск в таблице на листе B (планирование глобальных поисков).

Я хочу, чтобы он пропускал ошибки и ничего не возвращал.

Я пробовал метод заполнения и копирования и вставки, ни один из которых я не могу заставить работать с формулой. Кажется, они просто хотят заполнить значением из исходной формулы.

Я думаю, что это не работает из-за скачков между листами, с которыми я сталкивался в разных вычислениях.

Я не один, чтобы просто попробовать один или два раза, так что это определенно я в конце моей веревки.

Dim GlobalExpPct As Variant

Range("AI2").Select  'Gets historical rates from Plan Global Lookups tab
Do
On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, -24), Sheets("Plan Global Lookups").Range("A:B"), 2, False)
ActiveCell.value = GlobalExpPct
GlobalExpPct = vbNullString
ActiveCell.Offset(1, 0).Select

Loop While ActiveCell.Row < 1000 'have this in place to keep it from looping through all the records

Я подозреваю, что медленная обработка происходит из-за выбора следующей ячейки каждый раз, а затем повторного вызова значений и формулы листа. Обычно я вижу, что формула возвращает либо нулевое значение, либо получает то же значение из предыдущей формулы при заполнении.

Спасибо за помощь заранее. Это отличный ресурс, так как мне удалось решить 99% моих проблем на этом сайте.

Редактировать

Этот код, предоставленный Ахмедом, прекрасно работает, но мне нужен еще один критерий:

Если дополнительный столбец (базовый класс учетной записи «T») - «IP», то мы можем использовать «Планирование глобальных поисков A: B» в соответствии с текущей настройкой. Однако, если он заполнен иначе, нам нужно извлечь из поиска другой столбец. Мы можем продублировать таблицу на том же листе или по-прежнему использовать столбец A при поиске плана, в зависимости от того, что является наиболее эффективным. Вот код, который стоит сегодня, который отлично работает:

Sub GetGlobals()

Dim IntervalProcessing60k As Integer
Dim SRow As Long
Dim ERow As Long
Dim Src As Variant
Dim AcctPlan
Dim GlobalExpPct As Variant
Dim AcctPlanRng As Range
Dim Rslt() As Variant
Dim t As Date
Dim GetGlobalTime As Date
Dim ActWs As Worksheet
Dim ATBAllowResCalc As Worksheet


Set ActWs = ThisWorkbook.ActiveSheet
Set PlanGlobalWs = ThisWorkbook.Sheets("Plan Global Lookups")
Set ATBAllowResCalc = ThisWorkbook.Sheets("ATB-Allowance Reserving-Calc")
Set AcctGlobalRng = PlanGlobalWs.Range("A1:B" & PlanGlobalWs.Cells(PlanGlobalWs.Rows.Count, 1).End(xlUp).Row)

t = Now()
LastRow = Range("A" & Rows.Count).End(xlUp).Row

IntervalProcessing60k = 0
SRow = 2
ERow = LastRow
Src = ActWs.Range("K" & SRow & ":K" & ERow).value
X = 1
For Rw = SRow To ERow
AcctPlan = Src(Rw - SRow + 1, 1)
    On Error Resume Next
GlobalExpPct = Application.WorksheetFunction.VLookup(AcctPlan, AcctGlobalRng, 2, False)
On Error GoTo 0
ReDim Preserve Rslt(1 To X)
Rslt(X) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
GlobalExpPct = vbNullString
If Rw > 120000 Then Debug.Print Rw, X, Src(Rw - SRow + 1, 1), Rslt(X)
        If X = 60000 Then
        ActWs.Range("AI" & IntervalProcessing60k * 60000 + SRow).Resize(UBound(Rslt, 1), 1).value = Application.Transpose(Rslt)
        IntervalProcessing60k = IntervalProcessing60k + 1
        X = 1
        ReDim Rslt(1 To 1)
        Else
        X = X + 1
        End If
    Next Rw

ActWs.Range("AI" & IntervalProcessing60k * 60000 + SRow).Resize(UBound(Rslt, 1), 1).value = Application.Transpose(Rslt)

GetGlobalTime = Format(Now() - t, "hh:mm:ss")

End Sub

Answer 1

Последний ответ изменен для повышения эффективности и новых требований. Время тестирования для обработки около 120 К строк составляет всего около 6 секунд.дополнительно столбец «T» проверяется на значение «IP» и значение поиска, извлекаемое из столбца B или C. соответственно.

Option Explicit
Sub GetGlobals()
Dim SRow As Long
Dim ERow As Long
Dim Src As Variant, Src2 As Variant
Dim AcctPlan
Dim GlobalExpPct As Variant
Dim AcctPlanRng As Range
Dim Rslt() As Variant
Dim tm As Double
Dim ActWs As Worksheet, PlanGlobalWs As Worksheet
Dim AcctGlobalRng As Range
Dim ATBAllowResCalc As Worksheet
Dim LastRow As Long, X As Long, Rw As Long
Dim LookArr As Variant, LookUpCol As Integer

Set ActWs = ThisWorkbook.ActiveSheet
Set PlanGlobalWs = ThisWorkbook.Sheets("Plan Global Lookups")
'Set ATBAllowResCalc = ThisWorkbook.Sheets("ATB-Allowance Reserving-Calc")
Set AcctGlobalRng = PlanGlobalWs.Range("A1:C" & PlanGlobalWs.Cells(PlanGlobalWs.Rows.Count, 1).End(xlUp).Row)
LookArr = AcctGlobalRng.Value

tm = Timer
LastRow = Range("K" & Rows.Count).End(xlUp).Row

SRow = 2
ERow = LastRow
Src = ActWs.Range("K" & SRow & ":K" & ERow).Value
Src2 = ActWs.Range("T" & SRow & ":T" & ERow).Value
ReDim Rslt(1 To ERow - SRow + 1, 1 To 1)

    For Rw = SRow To ERow
    AcctPlan = Src(Rw - SRow + 1, 1)
    GlobalExpPct = ""
       For X = 1 To UBound(LookArr, 1)
            If AcctPlan = LookArr(X, 1) Then
            LookUpCol = IIf(Src2(Rw - SRow + 1, 1) = "IP", 2, 3)    
            GlobalExpPct = LookArr(X, LookUpCol)
            Exit For
            End If
       Next X
    GlobalExpPct = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
    Rslt(Rw - SRow + 1, 1) = GlobalExpPct
    Next Rw

ActWs.Range("AI" & SRow).Resize(UBound(Rslt, 1), 1).Value = Rslt
Debug.Print " Time in second " & Timer - tm; ""
End Sub

Answer 2

Можно попробовать и посмотреть, улучшится ли производительность

Sub testModified()
Dim GlobalExpPct As Variant, Rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet, tm As Double
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'this would be more efficent
Set Rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)

    For Rw = 2 To 1000
    ValtoLook = ActWs.Range("AI" & Rw).Offset(0, -24).Value
    On Error Resume Next
    GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, Rng, 2, False)
    On Error GoTo 0
    Range("AI" & Rw).Value = GlobalExpPct
    GlobalExpPct = vbNullString
    Next Rw
Debug.Print " Time in second " & Timer - tm; ""
End Sub

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

Это может быть эффективно, если вы подтвердите, что все значения столбца K и AI являются значениями, и они не взаимозависимы с некоторыми формулами и т. Д. Приведенного выше кода может оказаться достаточно для 1000 строк. Но для тяжелых файлов с 10-1000 К строк, код должен быть более эффективным. в этом случае операции с ячейками Excel должны быть минимизированы с помощью массива. Добавление вышеуказанного кода, модифицированного с помощью Array

Sub testModifiedArray()
Dim GlobalExpPct As Variant, Rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet
Dim Rslt() As Variant, Src As Variant, tm As Double
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'next line would be more efficent, You may define range directly if you know the end row
Set Rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)
Src = ActWs.Range("K2:K1000").Value
    For Rw = 2 To 1000
    ValtoLook = Src(Rw - 1, 1)
    On Error Resume Next
    GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, Rng, 2, False)
    On Error GoTo 0
    ReDim Preserve Rslt(1 To Rw - 1)
    Rslt(Rw - 1) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
    'Debug.Print Rslt(Rw - 1)
    GlobalExpPct = vbNullString
    Next Rw
ActWs.Range("AI2").Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)

Debug.Print " Time in second " & Timer - tm; ""
End Sub

И код, протестированный с моим «Угадай столбец», и диапазоны. Поскольку я лично не предпочитаю отключать вычисления, обработку событий и обновление экрана (в обычных случаях), я не добавил эти стандартные строки. Однако вы можете использовать эти стандартные методы в зависимости от состояния рабочего файла.

Редактировать: изменено, чтобы приспособиться к преодоленному пределу транспонирования массива в 65 КБ

Option Explicit
Sub testModifiedArray2()
Dim GlobalExpPct As Variant, rng As Range, Rw As Long
Dim ValtoLook, Ws As Worksheet, ActWs As Worksheet
Dim Rslt() As Variant, Src As Variant, tm As Double
Dim Chunk60K As Integer, X As Long, SRow As Long, ERow As Long
tm = Timer
Set ActWs = ThisWorkbook.ActiveSheet
Set Ws = ThisWorkbook.Sheets("Plan Global Lookups")
'Set Rng = Ws.Range("A:B")
'next line would be more efficent, You may define range directly if you know the end row
Set rng = Ws.Range("A1:B" & Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row)

Chunk60K = 0
SRow = 2
ERow = 120030
Src = ActWs.Range("K" & SRow & ":K" & ERow).Value
X = 1
    For Rw = SRow To ERow
    ValtoLook = Src(Rw - SRow + 1, 1)
    On Error Resume Next
    GlobalExpPct = Application.WorksheetFunction.VLookup(ValtoLook, rng, 2, False)
    On Error GoTo 0
    ReDim Preserve Rslt(1 To X)
    Rslt(X) = IIf(IsNull(GlobalExpPct), "", GlobalExpPct)
    GlobalExpPct = vbNullString
    If Rw > 120000 Then Debug.Print Rw, X, Src(Rw - SRow + 1, 1), Rslt(X)
        If X = 60000 Then
        ActWs.Range("AI" & Chunk60K * 60000 + SRow).Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)
        Chunk60K = Chunk60K + 1
        X = 1
        ReDim Rslt(1 To 1)
        Else
        X = X + 1
        End If
    Next Rw


ActWs.Range("AI" & Chunk60K * 60000 + SRow).Resize(UBound(Rslt, 1), 1).Value = Application.Transpose(Rslt)

Debug.Print " Time in second " & Timer - tm; ""
End Sub