excel - 简单的循环，但通过 50 000+ 行

Question

基于超过 1 500 000 行的数据库，我每天几乎没有要创建的报告......
我的 2 个模块真的很慢，我想这来自我为 50 000 行添加的循环。
多年来我一直在做简单的 VBA，但我不知道如何加快速度。
你有什么机会可以帮助解决这个问题吗？
请

MasterLastRow = WS_Mast_QCF.Cells(Rows.Count, 2).End(xlUp).Row

Set LibDisc = WB_Master.Worksheets("Lib_Disc").Range("A2:C100")
Set LibSS = WB_Master.Worksheets("Lib_SS").Range("D2:G10000")
Set LibMod = WB_Master.Worksheets("Lib_Mod").Range("B2:G1000")

      
For n = 2 To MasterLastRow
On Error Resume Next
    
    Modu = WS_Mast_QCF.Range("B" & n).Value
    SS = WS_Mast_QCF.Range("E" & n).Value
    Disc = WS_Mast_QCF.Range("G" & n).Value
    QCFStatus = WS_Mast_QCF.Range("N" & n).Value

    With Application.WorksheetFunction
        WS_Mast_QCF.Range("A" & n) = .VLookup(Modu, LibMod, 6, False)
        WS_Mast_QCF.Range("C" & n) = .VLookup(SS, LibSS, 3, False)
        WS_Mast_QCF.Range("D" & n) = .VLookup(SS, LibSS, 4, False)
        WS_Mast_QCF.Range("F" & n) = .VLookup(SS, LibSS, 2, False)
        WS_Mast_QCF.Range("G" & n) = .VLookup(Disc, LibDisc, 3, False)
    End With
    
    If SS = "" Then
        WS_Mast_QCF.Range("C" & n & ":F" & n) = "TBD"
    End If

    ' QCF Status Treatment
        Select Case QCFStatus
            Case Is = "Inspection Step", "Open RFI"
                WS_Mast_QCF.Range("H" & n).Value = "Pending"
                WS_Mast_QCF.Range("N" & n).Value = ""
            Case Is <> "Inspection Step", "Open RFI"
                WS_Mast_QCF.Range("H" & n).Value = "Done"
        End Select
Next n

Answer 1

在 Excel-VBA 中开发时，您应该遵循几条规则以获得最佳性能，正如我在上一个答案 (https://stackoverflow.com/a/19167804/109122) 中概述的那样。总而言之，尽量减少 VBA 与 Excel 模型/电子表格的交互，主要是通过使用 Range-Array 复制而不是读取和写入单个单元格和/或范围。
此外，正如我在上面的评论中提到的，通常优化循环的方式是找到将工作移出循环的方法。
将这两者结合起来，我导出了下面的代码作为执行此操作的一种方法。没有您的数据/电子表格，我无法对其进行测试，但它应该非常接近正常工作，并且速度会快很多倍。请注意，这段代码要长得多，主要是因为我包含了 Dim语句，因为我保留了一些中间步骤(如 Lib* 变量)，以便更容易看到它与原始代码的关系。

MasterLastRow = WS_Mast_QCF.Cells(Rows.Count, 2).End(xlUp).Row

Set LibDisc = WB_Master.Worksheets("Lib_Disc").Range("A2:C100")
Set LibSS = WB_Master.Worksheets("Lib_SS").Range("D2:G10000")
Set LibMod = WB_Master.Worksheets("Lib_Mod").Range("B2:G1000")

' Copy the lookup ranges values into arrays
Dim DiscA() As Variant, SSA() As Variant, ModA() As Variant
DiscA = LibDisc.Value
SSA = LibSS.Value
ModA = LibMod.Value

' Make dictionaries of VLookup indexes
Dim VlookupMod As Scripting.Dictionary 'note: must add "Microsoft Sripting Runtime" in Add Tools References
Dim VlookupSS As Scripting.Dictionary
Dim VlookupDisc As Scripting.Dictionary
Set VlookupDisc = BuildVLookupDictionary(DiscA)
Set VlookupMod = BuildVLookupDictionary(ModA)
Set VlookupSS = BuildVLookupDictionary(SSA)

' Copy the read/writeable area into two arrays
Dim QcfA() As Variant, QCFStatusA() As Variant
QcfA = WS_Mast_QCF.Range("A1:H50000").Value
QCFStatusA = WS_Mast_QCF.Range("N1:N50000").Value

' Define some convenient column indexes
Const Ax = 1: Const Bx = 2: Const Cx = 3: Const Dx = 4: Const Ex = 5
Const Fx = 6: Const Gx = 7: Const Hx = 8

' loop through every row
For n = 2 To MasterLastRow
On Error Resume Next
    
    Modu = QcfA(n, Bx)
    SS = QcfA(n, Ex)
    Disc = QcfA(n, Gx)
    QCFStatus = QCFStatusA(n, 1)

    QcfA(n, Ax) = ModA(VlookupMod(Modu), 6)
    QcfA(n, Cx) = SSA(VlookupSS(SS), 3)
    QcfA(n, Dx) = SSA(VlookupSS(SS), 4)
    QcfA(n, Fx) = SSA(VlookupSS(SS), 2)
    QcfA(n, Gx) = DiscA(VlookupDisc(Disc), 3)
    
    If SS = "" Then
        QcfA(n, Cx) = "TBD"
        QcfA(n, Dx) = "TBD"
        QcfA(n, Ex) = "TBD"
        QcfA(n, Fx) = "TBD"
    End If

    ' QCF Status Treatment
    Select Case QCFStatus
        Case Is = "Inspection Step", "Open RFI"
            QcfA(n, Hx) = "Pending"
            QCFStatusA(n, 1) = ""
        Case Is <> "Inspection Step", "Open RFI"
            QcfA(n, Hx) = "Done"
    End Select
Next n

' Copy the modified arrays back into their ranges
WS_Mast_QCF.Range("A1:H50000").Value = QcfA
WS_Mast_QCF.Range("N1:N50000").Value = QCFStatusA

这使用了我编写的一个函数来简化构建替换 VLookup 调用的字典:

Function BuildVLookupDictionary(ValuesArray() As Variant) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    
    'ignore duplicate key errors
    On Error Resume Next
    
    For r = 1 To UBound(ValuesArray, 1)
        dict.Add ValuesArray(r, 1), r
    Next r
    
    On Error GoTo 0
    Set BuildVLookupDictionary = dict
End Function