提高高级filter处理时间
下面的代码通过logging进行循环，并从每个logging的高级filter/计算中返回某些值。 我有大约2000条logging我需要它贯穿。 问题是处理时间是10-15秒一个logging，这太慢了。
Sub EquityAutomatedDallas() Dim Counter As Integer Dim LogNo As String Dim LogNoRange As Range Dim NoRange As Range Dim FilterRange As Range Dim FilterCriteriaRange As Range Dim ValueRange As Range Dim FullSortRange As Range Dim SortValueRange As Range Dim FullSortRangeValues Dim EquityRankRange As Range Dim EquityOutOfRange As Range Dim MedianRange As Range Dim PropertyValueRange As Range Dim DifferenceRange As Range Dim MinRange As Range Dim MaxRange As Range Dim AverageRange As Range Dim DallasRes As Worksheet Set LogNoRange = Worksheets("EquitySpreadsheet").Range("B10") Set NoRange = Worksheets("Dallas Res").Range("A10:A647649") Set FilterRange = Worksheets("Dallas Res").Range("A9:T647649") Set FilterCriteriaRange = Worksheets("Dallas Res").Range("A1:T2") Set ValueRange = Worksheets("Dallas Res").Range("T10:T647649") Set FullSortRange = Worksheets("Dallas Res").Range("A9:S647649") Set SortValueRange = Worksheets("Dallas Res").Range("T9") Set FullSortRangeValues = Worksheets("Dallas Res").Range("A10:T647649") Set DallasRes = Worksheets("Dallas Res") Set EquityRankRange = Worksheets("EquityList").Range("P5") Set EquityOutOfRange = Worksheets("EquityList").Range("P4") Set MedianRange = Worksheets("EquityList").Range("O6") Set PropertyValueRange = Worksheets("EquityList").Range("D5") Set DifferenceRange = Worksheets("EquityList").Range("O7") Set MinRange = Worksheets("EquityList").Range("O8") Set MaxRange = Worksheets("EquityList").Range("O9") Set AverageRange = Worksheets("EquityList").Range("O10") Application.ScreenUpdating = False For Counter = 558 To 565 LogNo = Worksheets("Hirschy").Cells(1 + Counter, 1).Value LogNoRange = LogNo NoRange.ClearContents Application.Calculate If Not Application.CalculationState = xlDone Then DoEvents End If Application.Calculation = xlManual FilterRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=FilterCriteriaRange, Unique:=False Application.Calculation = xlCalculationAutomatic NoRange.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=Subtotal(3,R10C2:RC[1])" ValueRange.SpecialCells(xlCellTypeVisible).Formula = "=INDEX(EquitySpreadsheet!$C$12:$GT$29,16,(MATCH(INDIRECT(ADDRESS(ROW(),1)),EquitySpreadsheet!$C$12:$GS$12)+1))" DallasRes.Select FullSortRange.Select SortValueRange.Activate ActiveWorkbook.Worksheets("Dallas Res").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Dallas Res").Sort.SortFields.Add Key:=ValueRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Dallas Res").Sort .SetRange FullSortRangeValues .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Worksheets("Dallas Res").Calculate Worksheets("EquitySpreadsheet").Calculate Worksheets("EquityList").Calculate Worksheets("Hirschy").Cells(1 + Counter, 6) = EquityRankRange Worksheets("Hirschy").Cells(1 + Counter, 7) = EquityOutOfRange Worksheets("Hirschy").Cells(1 + Counter, 8) = MedianRange Worksheets("Hirschy").Cells(1 + Counter, 9) = PropertyValueRange Worksheets("Hirschy").Cells(1 + Counter, 10) = DifferenceRange Worksheets("Hirschy").Cells(1 + Counter, 11) = MinRange Worksheets("Hirschy").Cells(1 + Counter, 12) = MaxRange Worksheets("Hirschy").Cells(1 + Counter, 13) = AverageRange Next Counter Application.ScreenUpdating = True End Sub 无论如何，我可以加快这个macros吗？
正如注释中所解释的那样，在循环内部打开和closures计算可能是不需要的，除非您有其他计算取决于更新的值
您的代码清理帮助，我清理了一些，但可能会影响性能的主要变化是消除循环外的计算开关
这是未经testing，所以确保你最终的预期值; 如果它起作用，它可能会使速度更快
Sub EquityAutomatedDallas() Dim i As Long, LogNoRng As Range Dim wsHi As Worksheet: Set wsHi = Worksheets("Hirschy") Dim wsES As Worksheet: Set wsES = Worksheets("EquitySpreadsheet") Dim wsEL As Worksheet: Set wsEL = Worksheets("EquityList") Dim wsDa As Worksheet: Set wsDa = Worksheets("Dallas Res") Dim subTotalsDa As Range: Set subTotalsDa = wsDa.Range("A10:A647649") Dim fltrRng As Range: Set fltrRng = wsDa.Range("A9:T647649") Dim fltrCritRng As Range: Set fltrCritRng = wsDa.Range("A1:T2") Dim valRngDa As Range: Set valRngDa = wsDa.Range("T10:T647649") Dim fullSrtRng As Range: Set fullSrtRng = wsDa.Range("A9:S647649") Dim sortValRng As Range: Set sortValRng = wsDa.Range("T9") Dim fullSortRngVal As Range: Set fullSortRngVal = wsDa.Range("A10:T647649") Dim equityRankRng As Range: Set equityRankRng = wsEL.Range("P5") Dim equityOutOfRng As Range: Set equityOutOfRng = wsEL.Range("P4") Dim medianRng As Range: Set medianRng = wsEL.Range("O6") Dim propValRng As Range: Set propValRng = wsEL.Range("D5") Dim diffRng As Range: Set diffRng = wsEL.Range("O7") Dim minRng As Range: Set minRng = wsEL.Range("O8") Dim maxRng As Range: Set maxRng = wsEL.Range("O9") Dim avgRng As Range: Set avgRng = wsEL.Range("O10") xlEnableWB False 'Turns OFF everything, including automatic calculations For i = 558 To 565 LogNoRng = wsHi.Cells(1 + i, 1).Value2 subTotalsDa.ClearContents fltrRng.AdvancedFilter Action:=xlFilterInPlace, _ CriteriaRange:=fltrCritRng, Unique:=False subTotalsDa.SpecialCells(xlCellTypeVisible).FormulaR1C1 = _ "=Subtotal(3,R10C2:RC[1])" valRngDa.SpecialCells(xlCellTypeVisible).Formula = _ "=INDEX(EquitySpreadsheet!$C$12:$GT$29,16,(MATCH(INDIRECT(ADDRESS(ROW(),1)),EquitySpreadsheet!$C$12:$GS$12)+1))" With wsDa.Sort .SortFields.Clear .SortFields.Add Key:=valRngDa, SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .SetRng fullSortRngVal .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .Apply End With With wsHi .Cells(1 + i, 6) = equityRankRng: .Cells(1 + i, 7) = equityOutOfRng .Cells(1 + i, 8) = medianRng: .Cells(1 + i, 9) = propValRng .Cells(1 + i, 10) = diffRng: .Cells(1 + i, 11) = minRng .Cells(1 + i, 12) = maxRng: .Cells(1 + i, 13) = avgRng End With Next Application.Calculate xlEnableWB True 'Turns ON everything, including automatic calculations End Sub
打开和closuresExcelfunction的function（屏幕，计算等）
Public Sub xlEnableWB(Optional ByVal opt As Boolean = True) With Application .Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual) .DisplayAlerts = opt .DisplayStatusBar = opt .EnableAnimations = opt .EnableEvents = opt .ScreenUpdating = opt End With xlEnableWS , opt End Sub Public Sub xlEnableWS(Optional ws As Worksheet = Nothing, Optional opt As Boolean = True) If ws Is Nothing Then For Each ws In Application.ActiveWorkbook.Sheets: EnableWS ws, opt: Next Else EnableWS ws, opt End If End Sub Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean) With ws .DisplayPageBreaks = False .EnableCalculation = opt .EnableFormatConditionsCalculation = opt .EnablePivotTable = opt End With End Sub