改进高级过滤器处理时间

Question

下面的代码通过记录进行循环，并从每个记录的高级过滤器/计算中返回某些值。我有大约2000条记录需要它通过。问题是处理时间是10-15秒的记录，这太慢了。

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 

有没有反正我可以加快这个宏？

Answer 1

正如在评论解释，开启和关闭的计算循环内可能是不需要的，除非你有依赖于更新值

你的代码清理帮助其他计算，我清理了多一点，但可能会影响性能的主要变化是取消循环外部的计算切换

这是未经测试的，因此请确保最终获得预期值;如果它的工作原理可能使其更快

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 

---

功能打开和关闭Excel功能（屏幕，计算等）

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