改善高级过滤处理时间

时间:2015-10-18 22:56:18

标签: excel vba excel-vba

下面的代码遍历记录并从每个记录的高级过滤器/计算中返回某些值。我有大约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

无论如何我可以加速这个宏吗?

1 个答案:

答案 0 :(得分: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