vba - Excel 中具有大型数据集的 VBA 子例程的速度问题

Question

我正在创建一个相当广泛的 Excel 宏，以帮助在将文件导入我们公司的系统之前捕获文件中的常见错误。经过大约一个月的开发，我已经将大部分功能编码到多个 Sub 中(为了便于维护)，我从我的主 Sub Alfred() 中调用它们。

Sub Alfred() 'the butler 

    Application.ScreenUpdating = False
     Call fileCheck       '  0.57 seconds for 15000 rows
     Call symbolCheck     ' 31.57 seconds for 15000 rows
     Call trimTheHedges   ' 16.21 seconds for 15000 rows
     Call ctdCheck        '  0.28 seconds for 15000 rows
     Call lengthCheck     '  2.21 seconds for 15000 rows
     Call dupKeywordCheck '  0.54 seconds for 15000 rows
     Call colorCheck      '  2.56 seconds for 15000 rows
     Call PRTCheck        '  0.65 seconds for 15000 rows
     Call lminCheck       '139.26 seconds for 15000 rows <- See if we can decrease this and make one for RUSH too
     Call colOpNaCheck    '  0.80 seconds for 15000 rows
     Call colAddCLCheck   '  0.77 seconds for 15000 rows
     Call prodNumCheck    '  1.15 seconds for 15000 rows
     Call bpCheck         '  4.85 seconds for 15000 rows
     Call ucCheck         ' 10.75 seconds for 15000 rows
''''''''''''''''''''''''''''''''''''''''''''''
'''''Total 3.4992 minutes''209.95 seconds'''''
''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = True
End Sub

在为每个子任务计时后，我意识到我的一个子任务需要太长时间才能完成(子lminCheck)。我希望有人知道如何更好地完成我使用这个特定 Sub 执行的任务。如果可以的话，请提供任何可能加速此任务的方法的示例(尽可能具体)。我已经关闭了 ScreenUpdating 并且不确定将 Calculation 转换为 xlCalculationManual 会有多大帮助(也许我错了？)，但我真的在寻找一种方法重组我的代码(也许使用数组、更好的编码实践等)，这将提高我的 Sub 的处理时间。

'Checks for LMIN:Y Upcharge Criteria and checks off
'LMIN column of products where LMIN:Y exists
'Run this sub after sub that checks for empty criteria 1/invalid upcharges
'Columns CT & CU are Upcharge Criteria 1 & 2 and Column CP is LMIN
Private Sub lminCheck()

Dim endRange As Integer
Dim usedRange As Range
Dim row As Integer
Dim totalCount As Integer
Dim xid As String
Dim mainProdLine As String

endRange = ActiveSheet.Cells(Rows.count, "CS").End(xlUp).row
Set usedRange = ActiveSheet.Range("CT2:CU" & endRange)

'Count how many times LMIN:Y Upcharge criteria appears in Upcharge 1 & 2 columns
totalCount = WorksheetFunction.CountIf(usedRange, "*LMIN:Y*")

If totalCount <> 0 Then
    Dim lminCount As Integer
    For lminCount = 1 To totalCount
        'This gives us the row of this occurance
        row = Find_nth(usedRange, "LMIN:Y", lminCount)
        'Using row we can look at Column A of the same row to get the XID of the product
        xid = ActiveSheet.Range("A" & row).Value
        'Once we have the xid we can find the main/first line of the product
        Dim tempRange As Range
        Set tempRange = ActiveSheet.Range("A2:A" & endRange)
        mainProdLine = Find_nth(tempRange, xid, 1)
        'Using the main/first line of the product we can now check if the LMIN column is checked
        If ActiveSheet.Range("CP" & mainProdLine).Value <> "Y" Then
            'If column is not checked then check it
            ActiveSheet.Range("CP" & mainProdLine).Value = "Y"
        End If
    Next lminCount
Else
    'Exit entire sub since there are no instances of LMIN:Y to check
    Exit Sub
End If

End Sub

'This is the modified version of the Find_nth Function that is also able to find values if they are in the beginning of a string
Function Find_nth(rng As Range, strText As String, occurence As Integer)
Dim c As Range
Dim counter As Integer
For Each c In rng
    If c.Value = strText Then counter = counter + 1
    If InStr(1, c, strText) = 1 And c.Value <> strText Then counter = counter + 1
    If InStr(1, c, strText) > 1 Then counter = counter + 1
    If counter = occurence Then
        Find_nth = c.row
        '.Address(False,False) eliminates absolute reference ($x$y)
        Exit Function
    End If
Next c
End Function

Answer 1

这应该更快一点:理想情况下，您会在一次遍历数据中找到所有实例，返回具有搜索文本的所有不同行号。

Function Find_nth(rng As Range, strText As String, occurence As Integer)

    Dim arr As Range, r As Long, c As Long, v, r1 As Long
    Dim counter As Integer

    r1 = rng.Cells(1).Row
    arr = rng.Value
    For r = 1 To UBound(arr, 1)
        For c = 1 To UBound(arr, 2)
            v = arr(r, c)
            If v Like "*" & strText & "*" Then counter = counter + 1
            If counter = occurence Then
                Find_nth = (r1 + r) - 1
                Exit Function
            End If
        Next c
    Next r
End Function