下面的代码遍历记录并从每个记录的高级过滤器/计算中返回某些值。我有大约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
无论如何我可以加速这个宏吗?
答案 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