使用Excel中的大数据集加速VBA子例程的问题

我正在创build一个相当广泛的Excelmacros，以便在将文件导入到我们公司的系统之前，帮助捕捉文件上的常见错误。 经过大约一个月的开发，我已经将大部分的function编码到多个Subs（为了便于维护），我从我的主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 

定时每个子我意识到我的一个子需要太长时间才能完成（Sub lminCheck ）。 我希望有人可能有一个想法，我怎样才能更好地完成我使用这个特定的Sub执行的任务。 如果可以采取任何可能加速这一任务的方法，请提供示例（具体如您所能）。 我已经closuresScreenUpdating ，我不确定将Calculation转换为xlCalculationManual会有多大的帮助（也许我错了？），但是我确实在寻找一种方法来重构我的代码（也许使用一个数组，更好的编码实践等），这将改善我的子处理时间。

 '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

你有很多重复的循环。 为什么循环遍历所有的单元格，直到find匹配的时候，工作表的MATCH函数完成这个工作呢？

 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行的样本数据与10％的匹配花费了0.4秒，屏幕更新开启，屏幕更新closures0.2秒。}

Answer 2

这应该会更快一点：理想情况下，您可以通过数据查找所有实例，返回所有具有search文本的不同行号。

 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