加速 VBA for 循环，本质上是在 2 个数组中运行 vlookup 并填充输出数组

Question

我是一名 VBA 业余爱好者，所以我知道有一种更有效的方法来编写此代码。代码运行，但我试图减少运行时间。我在一个模块中有两个。这个运行大约需要 2m 50 秒，另一个需要 1m 25 秒。简而言之，我需要它在同一工作簿的另一个工作表中查找 id，在该行的其他列中查找条件，然后填充第一个工作表中的各个列id 匹配的工作表。

这是代码：

Sub Pref()
'insert account pref data into dataset

Dim wsP As Worksheet
Dim wIP As Worksheet
Dim lrow As Long
Dim lRow2 As Long
Dim b As Long
Dim bizArr As Variant
Dim outArr As Variant
Dim Searchfor As Variant
Dim p As Variant
Dim pArr As Variant

Set wsP = Sheets("Preferences")
    With wsP
    lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    pArr = Range(.Cells(1, 1), .Cells(lrow, 6))
    End With
    
Set wIP = Sheets("Working Issue Pay Data")
    With wIP
    lRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
    bizArr = Range(.Cells(1, 1), .Cells(lRow2, 1))
    outArr = Range(Cells(1, 17), Cells(lRow2, 27))
    End With

        On Error Resume Next
           For b = 2 To lRow2
           For p = 2 To lrow
           Searchfor = bizArr(b, 1)
           If pArr(p, 1) = Searchfor Then
               If pArr(p, 3) = "ACH" And pArr(p, 5) = "Yes" Then
                   outArr(b, 1) = pArr(p, 5)
               ElseIf pArr(p, 3) = "Payment" Then
                   outArr(b, 2) = pArr(p, 5)
                   outArr(b, 3) = pArr(p, 6)
               ElseIf pArr(p, 3) = "Lien" Then
                   outArr(b, 4) = pArr(p, 4)
                   outArr(b, 5) = pArr(p, 6)
               ElseIf pArr(p, 3) = "Defer Pay" And pArr(p, 5) = "Yes" Then
                   outArr(b, 7) = pArr(p, 5)
                   outArr(b, 8) = pArr(p, 6)
            Exit For
           End If
           End If
        Next p
        Next b
 
wIP.Range(Cells(1, 17), Cells(lRow2, 27)) = outArr

End Sub

我愿意完全更改代码。

我在结束 sub 之前添加了 Erase pArr、Erase bizArr、Erase outArr，看看是否有帮助。虽然，我不确定这是否有帮助，因为两个 subs 中使用了相同的 bizArr 和 outArr。

另外，我在运行时应用了这个优化代码：

Public Sub OptimizedMode(ByVal enable As Boolean)
' attempt to speed up Build macro

     Application.EnableEvents = Not enable
     Application.Calculation = IIf(enable, xlCalculationManual, xlCalculationAutomatic)
     Application.ScreenUpdating = Not enable
     Application.EnableAnimations = Not enable
     Application.DisplayStatusBar = Not enable
     Application.PrintCommunication = Not enable
     
End Sub

Answer 1

应该更快（使用

Match

而不是内循环）：

Sub Pref()
    Dim wsP As Worksheet, wIP As Worksheet
    Dim lr As Long, b As Long
    Dim bizArr As Variant, outArr As Variant, outRng As Range
    Dim Searchfor As Variant
    Dim p As Variant
    Dim pArr As Variant, matchRng As Range

    Set wsP = Sheets("Preferences")
    With wsP
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set matchRng = .Range("A1:A" & lr)
        pArr = matchRng.Resize(, 6).Value
    End With
    
    Set wIP = Sheets("Working Issue Pay Data")
    With wIP
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        bizArr = .Range(.Cells(1, 1), .Cells(lr, 1))
        Set outRng = .Range(.Cells(1, 17), .Cells(lRow2, 27))
        outArr = outRng.Value
    End With

    For b = 2 To UBound(bizArr, 1)
        'match against a worksheet is faster than nested loop
        m = Application.Match(bizArr(b, 1), matchRng, 0)
        If Not IsError(m) Then 'got a match?
            
            Select Case pArr(p, 3)
                Case "ACH"
                    If pArr(p, 5) = "Yes" Then outArr(b, 1) = pArr(p, 5)
                Case "Payment"
                    outArr(b, 2) = pArr(p, 5)
                    outArr(b, 3) = pArr(p, 6)
                Case "Lien"
                    outArr(b, 4) = pArr(p, 4)
                    outArr(b, 5) = pArr(p, 6)
                Case "Defer Pay"
                    If pArr(p, 5) = "Yes" Then
                        outArr(b, 7) = pArr(p, 5)
                        outArr(b, 8) = pArr(p, 6)
                    End If
            End Select
            
        End If 'got match
    Next b
 
    outRng.Value = outArr

End Sub