[英]Speed issues with VBA Sub Routine with large dataset in Excel
我正在創建一個相當廣泛的Excel宏來幫助捕獲文件中的常見錯誤,然后再將它們導入到我們公司的系統中。 經過大約一個月的開發,我已經將大部分功能編碼到多個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
在對每個子計時后我意識到我的一個Subs需要太長時間才能完成(Sub lminCheck
)。 我希望有人可能知道如何更好地完成我使用這個特定Sub執行的任務。 如果可以使用任何可能加速此任務的方法,請提供示例(盡可能具體)。 我已經關閉ScreenUpdating
並且我不確定將計算轉換為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
這應該快一點:理想情況下,您會在一次傳遞數據中找到所有實例,返回所有具有搜索文本的不同行號。
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
你有很多重復的循環。 為什么循環遍歷所有單元格,直到找到匹配項時,工作表的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秒,屏幕更新關閉時為0.2秒。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.