为什么我的宏运行缓慢而逐步运行却很快？

时间：2019-06-10 04:30:05

标签： excel vba

我正在尝试从表（而不是数据透视表）中过滤数据，然后将箱线图和散点图移动到不同的工作表。我尝试通过在开始时循环来完成此操作，但是我不知道如何命名，因为每个“类别”的名称都不相同，而且我想将图表复制为图片，并在将它们粘贴到不同的工作表时对其进行命名。我的宏很少在5分钟内运行，但是9/10次需要60分钟才能完成。但是，如果我逐步运行它，它会完美运行。希望可以有人帮帮我。以下是我的代码的一部分。实际上有10个类别（下面仅显示2个类别），因此它确实又长又重。

Sub CreateCharts()

'CreateCharts Macro


'Speed up the macro

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Application.DisplayStatusBar = False

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False


'Filter data

    ThisWorkbook.Sheets("DATA").Select
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8, Criteria1:= _
        "Chart 01"

'CopyPaste boxplot charts

            ThisWorkbook.Sheets("Charts").ChartObjects("C1").CopyPicture
            Application.Goto Sheets("Sheet1").Range("B2")
            ActiveSheet.Pictures.Paste.Name = ("Sheet1_C1")

            ThisWorkbook.Sheets("Charts").ChartObjects("C2").CopyPicture
            Application.Goto Sheets("Sheet1").Range("B39")
            ActiveSheet.Pictures.Paste.Name = ("Sheet1_C2")


'Refresh calculation on the data of scatter plots

    ThisWorkbook.Worksheets("Data_Cust").Calculate
    ThisWorkbook.Worksheets("Data_Prod").Calculate

'Activate data labels

    Sheets("Charts").ChartObjects("C3").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C3").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False


    Sheets("Charts").ChartObjects("C4").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C4").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False


    Sheets("Charts").ChartObjects("C5").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C5").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False

'CopyPaste scatter charts

            ThisWorkbook.Sheets("Charts").ChartObjects("C3").CopyPicture
            Application.Goto Sheets("Sheet1").Range("X2")
            ActiveSheet.Pictures.Paste.Name = ("Sheet1_C3")

            ThisWorkbook.Sheets("Charts").ChartObjects("C4").CopyPicture
            Application.Goto Sheets("Sheet1").Range("X42")
            ActiveSheet.Pictures.Paste.Name = ("Sheet1_C4")

            ThisWorkbook.Sheets("Charts").ChartObjects("C5").CopyPicture
            Application.Goto Sheets("Sheet1").Range("X80")
            ActiveSheet.Pictures.Paste.Name = ("Sheet1_C5")


'Filter data

    ThisWorkbook.Sheets("DATA").Select
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=8, Criteria1:= _
        "Chart 02"

'CopyPaste boxplot charts

            ThisWorkbook.Sheets("Charts").ChartObjects("C1").CopyPicture
            Application.Goto Sheets("Sheet1").Range("B2")
            ActiveSheet.Pictures.Paste.Name = ("Sheet2_C1")

            ThisWorkbook.Sheets("Charts").ChartObjects("C2").CopyPicture
            Application.Goto Sheets("Sheet2").Range("B39")
            ActiveSheet.Pictures.Paste.Name = ("Sheet2_C2")


'Refresh calculation on the data of scatter plots

    ThisWorkbook.Worksheets("Data_Cust").Calculate
    ThisWorkbook.Worksheets("Data_Prod").Calculate

'Activate data labels

    Sheets("Charts").ChartObjects("C3").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C3").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False


    Sheets("Charts").ChartObjects("C4").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C4").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False


    Sheets("Charts").ChartObjects("C5").Activate
    ActiveChart.ApplyDataLabels
    ActiveSheet.ChartObjects("C5").Activate
    ActiveChart.FullSeriesCollection(1).DataLabels.Select
    Selection.ShowRange = False
    Selection.ShowRange = True
    Selection.AutoText = True
    Application.CommandBars("Format Object").Visible = False

'CopyPaste scatter charts

            ThisWorkbook.Sheets("Charts").ChartObjects("C3").CopyPicture
            Application.Goto Sheets("Sheet2").Range("X2")
            ActiveSheet.Pictures.Paste.Name = ("Sheet2_C3")

            ThisWorkbook.Sheets("Charts").ChartObjects("C4").CopyPicture
            Application.Goto Sheets("Sheet2").Range("X42")
            ActiveSheet.Pictures.Paste.Name = ("Sheet2_C4")

            ThisWorkbook.Sheets("Charts").ChartObjects("C5").CopyPicture
            Application.Goto Sheets("Sheet2").Range("X80")
            ActiveSheet.Pictures.Paste.Name = ("Sheet2_C5")


Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayStatusBar = True

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

End Sub

2 个答案:

答案 0 :(得分：1)

两件事将帮助您优化代码：

  • 摆脱所有Select / Activate // GoTo的
  • 将通用代码提取到Sub中

完成此操作后，它将对速度有所帮助，并且您会发现它更容易调试和进一步优化代码

Option Explicit

Sub CreateCharts()
    Dim wsData As Worksheet
    Dim loData As ListObject
    Dim wsCharts As Worksheet
    Dim rngDest As Range
    Dim chtCx As ChartObject

    On Error GoTo CleanUp
    'Speed up the macro
    SpeedUp

    ' Get refrences
    Set wsCharts = ThisWorkbook.Worksheets("Charts")
    Set wsData = ThisWorkbook.Worksheets("DATA")
    Set loData = wsData.ListObjects("Table1")

    'Filter data
    loData.Range.AutoFilter Field:=8, Criteria1:="Chart 01"

    'CopyPaste boxplot charts
    With ThisWorkbook.Worksheets("Sheet1")
        CopyChart wsCharts.ChartObjects("C1"), .Range("B2"), "Sheet1_C1"
        CopyChart wsCharts.ChartObjects("C2"), .Range("B39"), "Sheet1_C2"

        'Refresh calculation on the data of scatter plots
        ThisWorkbook.Worksheets("Data_Cust").Calculate
        ThisWorkbook.Worksheets("Data_Prod").Calculate

        'Activate data labels
        FormatSeries wsCharts.ChartObjects("C3")
        FormatSeries wsCharts.ChartObjects("C4")
        FormatSeries wsCharts.ChartObjects("C5")

        'CopyPaste scatter charts
        CopyChart wsCharts.ChartObjects("C3"), .Range("X2"), "Sheet1_C3"
        CopyChart wsCharts.ChartObjects("C4"), .Range("X42"), "Sheet1_C4"
        CopyChart wsCharts.ChartObjects("C5"), .Range("X80"), "Sheet1_C5"
    End With

    'Filter data
    loData.Range.AutoFilter Field:=8, Criteria1:="Chart 02"

    'CopyPaste boxplot charts
    With ThisWorkbook.Worksheets("Sheet2")
        CopyChart wsCharts.ChartObjects("C1"), .Range("B2"), "Sheet2_C1"
        CopyChart wsCharts.ChartObjects("C2"), .Range("B39"), "Sheet2_C2"

        'Refresh calculation on the data of scatter plots
        ThisWorkbook.Worksheets("Data_Cust").Calculate
        ThisWorkbook.Worksheets("Data_Prod").Calculate

        'Activate data labels
        FormatSeries wsCharts.ChartObjects("C3")
        FormatSeries wsCharts.ChartObjects("C4")
        FormatSeries wsCharts.ChartObjects("C5")

        'CopyPaste scatter charts
        CopyChart wsCharts.ChartObjects("C3"), .Range("X2"), "Sheet2_C3"
        CopyChart wsCharts.ChartObjects("C4"), .Range("X42"), "Sheet2_C4"
        CopyChart wsCharts.ChartObjects("C5"), .Range("X80"), "Sheet2_C5"
    End With
CleanUp:
    SpeedUp False
End Sub

Private Sub FormatSeries(Cht As ChartObject)
    Cht.Chart.ApplyDataLabels
    With Cht.Chart.FullSeriesCollection(1).DataLabels
        .ShowRange = False
        .ShowRange = True
        .AutoText = True
    End With
End Sub

Private Sub CopyChart(Cht As ChartObject, rngDst As Range, ChtName As String)
    Dim o As Object
    rngDst.Worksheet.Activate
    rngDst.Cells(1, 1).Select
    Cht.CopyPicture
    rngDst.Worksheet.Pictures.Paste.Name = ChtName
End Sub

Sub SpeedUp(Optional TurnOn As Boolean = True)
    Static OldCalc As XlCalculation
    Static OldStatus As Boolean
    Static OldPageBreaks As Boolean
    If TurnOn Then
        OldCalc = Application.Calculation: Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = False
        OldStatus = Application.DisplayStatusBar: Application.DisplayStatusBar = False
        Application.EnableEvents = False
        OldPageBreaks = ActiveSheet.DisplayPageBreaks: ActiveSheet.DisplayPageBreaks = False
    Else
        Application.Calculation = OldCalc
        Application.ScreenUpdating = True
        Application.DisplayStatusBar = OldStatus
        Application.EnableEvents = True
        ActiveSheet.DisplayPageBreaks = OldPageBreaks
    End If
End Sub

答案 1 :(得分：-1)

您必须学习如何使用With块对同一元素进行操作，并避免使用Select和Activate。它将使您的代码更快，更干净。

当我对速度进行故障排除时，我总是将其放在我的代码中，我想开始测量我的代码运行多长时间。可以在程序开始时，可​​以在以后：

Dim tim as double: tim = Timer

我使用下面的代码在即时窗口的日志中检查我的宏运行了多长时间（以秒为单位）。您可以将其放在多行中，以查看哪些代码片段很慢。将问题缩小到几行后，解决问题会容易得多。

Debug.Print "checkpoint 1 " & Timer - tim

您可能要在此行之后重置变量tim，否则下一个检查点将显示从开始起经过的时间，而不是从上一个检查点起经过的时间：

tim = Timer

我还会不时添加此行以清除剪贴板，该剪贴板会因粘贴而增长并减慢速度：

Application.CutCopyMode = False
相关问题
最新问题