简单循环但通过 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 中开发时，您应该遵循几条规则以获得最佳性能，正如我在之前的回答 () 中概述的那样。总结一下，尽量减少 VBA 与 Excel model/spreadsheet 的交互，主要是通过使用范围数组复制而不是读写单个单元格 and/or 范围。

此外，正如我在上面的评论中提到的，通常优化循环的方法是找到将工作移出循环的方法。

结合这两者，我得出了下面的代码作为一种方法。没有你的 data/spreadsheet 我无法测试它，但它应该非常接近正常工作并且会快很多倍。请注意，此代码明显更长，主要是因为我包含了 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

简单循环但通过 50 000 多行

Simple loop but through 50 000+ lines

excel

performance

vba

loops

line