使用Excel中的大型数据集加速VBA Sub Routine的问题

Question

I'm creating a rather extensive Excel macro to help catch common errors on files prior to importing them into our company's system. After about a month of development I've gotten the bulk of the functionality coded into multiple Subs (for ease of maintenance), which I call from my main 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

After timing each sub I realize that one of my Subs takes far too long to complete (Sub lminCheck ). I was hoping that someone might have an idea of how I can better accomplish the task I perform with this particular Sub. Please provide examples (as specifically as you can) if you can on any methods that could possibly speed up this task. I already turn off ScreenUpdating and I'm not sure turning Calculation to xlCalculationManual will help much (maybe I'm wrong?), but I'm really looking for a way to restructure my code (maybe using an array, a better coding practice, etc) that will improve the processing time of my 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

This should be a little faster: ideally you would find all instances in a single pass through the data, returning all the distinct row numbers which have the searched-for text.

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

Answer 2

You have a lot of repetitious looping. Why loop through all of the cells until you find a match when the worksheet's MATCH function does this so well?

Private Sub lminCheck()
    Dim c As Long, vCOLs As Variant
    Dim rLMINY As Range, vXID As Variant, dXIDs As Object

    Debug.Print Timer
    'application.screenupdating = false '<~~ uncomment this once you are no longer debugging
    Set dXIDs = CreateObject("Scripting.Dictionary")
    dXIDs.comparemode = vbTextCompare

    vCOLs = Array(98, 99)  '<~~ columns CT & CU

    With Worksheets("Upcharge") '<~~ surely you know what worksheet you are supposed to be on
        If .AutoFilterMode Then .AutoFilterMode = False
        For c = LBound(vCOLs) To UBound(vCOLs)
            With Intersect(.UsedRange, .Columns(vCOLs(c)))
                .AutoFilter field:=1, Criteria1:="*LMIN:Y*"
                With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                    If CBool(Application.Subtotal(103, .Cells)) Then
                        For Each rLMINY In .SpecialCells(xlCellTypeVisible)
                            dXIDs.Item(rLMINY.Offset(0, -(vCOLs(c) - 1)).Value2) = rLMINY.Value2
                        Next rLMINY
                    End If
                End With
                .AutoFilter
            End With
        Next c

        For Each vXID In dXIDs.keys
            .Cells(Application.Match(vXID, .Columns(1), 0), "CP") = "Y"
        Next vXID
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

    dXIDs.RemoveAll: Set dXIDs = Nothing
    Application.ScreenUpdating = True
    Debug.Print Timer

End Sub

^{15,000 rows of sample data with 10% matches took 0.4 seconds with screen updating on, 0.2 seconds with screen updating turned off.}