通过访问 VBA 非常慢的图表版

Question

我使用图表来显示带有 VBA 的 ms-access 2007 上的活动进度，我曾经使用 PivotCharts，它速度很快但不是真正可编辑的。我只需要显示过去的几个月，并在今年剩下的时间里制作隐形积分。

我的图表显示 2 系列 300 点（粒度增加），但我每月只显示一次数据标签。 我无法使用 Pivot Chart 逐点编辑，所以我转向了经典的 oldStyle Chart。

我的问题是我的编辑速度很慢，我已经阅读了很多关于 VBA 优化的内容，但没有任何效果 我为每条曲线测量了 20 秒，这对于我的层次结构来说是“不可接受的”。 我一直在考虑多线程，但它的工作量太大而收益却很小（%4？还是 %8？）

（仅供参考，积分等计算是在表格打开之前完成的，效果很好）

这是我这个慢图版的代码：

Dim intPntCount As Integer
Dim intTmp As Integer
Dim oSeries As Object
Dim colSeries As SeriesCollection
Dim oPnt As Object
Dim intCptSeries As Byte
Dim booPreviousZero As Boolean
Dim startDate, endDate As Date
Dim lngWhite, LngBlack As Long

lngWhite = RGB(255, 255, 255)
LngBlack = RGB(0, 0, 0)
linPlanned.BorderColor = RGB(251, 140, 60)
linCompleted.BorderColor = RGB(52, 84, 136)

lblUnit.Left = 1248 'use fctgetabsciisa chProgressFixs.Axes(2).MaximumScale / 80

With Me.chProgressFixs
    startDate = Now
    .BackColor = lngWhite
    intCptSeries = 0
    'colSeries = .SeriesCollection
    For Each oSeries In .SeriesCollection
        intCptSeries = intCptSeries + 1
        Debug.Print "Series" & intCptSeries
        booPreviousZero = True
        intPntCount = 1
        For Each oPnt In oSeries.Points
            oPnt.ApplyDataLabels
            If oPnt.DataLabel.Caption = "0" Then
                oPnt.Border.Weight = 1
                oPnt.DataLabel.Caption = vbNullString
                If booPreviousZero = False Then
                    oPnt.Border.Color = lngWhite
                    booPreviousZero = True
                Else
                    oPnt.Border.Color = LngBlack
                End If
            Else
                booPreviousZero = False
                oPnt.Border.Weight = 4
                oPnt.DataLabel.Font.Size = 14
                Select Case intCptSeries
                    Case 1: oPnt.Border.Color = linPlanned.BorderColor
                    Case 2: oPnt.Border.Color = linCompleted.BorderColor
                End Select

                If ((intPntCount + 30) / 30 <> Int((intPntCount + 30) / 30)) Then
                    If (intPntCount < oSeries.Points.Count) Then
                        If (intPntCount <> IntLastDispDay - 1) Then
                            oPnt.DataLabel.Caption = vbNullString
                        Else
                            oPnt.DataLabel.Font.Size = 20
                        End If
                     End If
                End If
            End If
            intPntCount = intPntCount + 1
        Next
        Debug.Print DateDiff("s", startDate, Now)
    Next
    Me.TimerInterval = 1
End With 

感谢大家的帮助

Answer 1

也许你需要避免屏幕刷新：

Application.ScreenUpdating = False

然后

Application.ScreenUpdating = true

完成后。如果您在除法时使用 \ insted of / 也会很有帮助，如果您不关心仅使用整数。试试看。

Answer 2

也许你应该替换：

If ((intPntCount + 30) / 30 <> Int((intPntCount + 30) / 30)) Then

类似的东西

If (((intPntCount + 30) MOD 30) > 0 ) Then

并测量执行时间。关于您的代码的另一件事是：

oPnt.DataLabel.Font.Size = 14

...也许应该在 if 中试图避免重写属性两次。尝试类似：

If (((intPntCount + 30) MOD 30) > 0 ) Then
    If (intPntCount < oSeries.Points.Count) Then
          If (intPntCount <> IntLastDispDay - 1) Then
                oPnt.DataLabel.Caption = vbNullString
                oPnt.DataLabel.Font.Size = 14
          Else
                oPnt.DataLabel.Font.Size = 20
          End If
Else
    oPnt.DataLabel.Font.Size = 14
    End If
Else
oPnt.DataLabel.Font.Size = 14
End If

即使预先计算也只是很小的改进

 (intPntCount + 30)

在变量之后

 intPntCount = intPntCount + 1

...并使用类似的东西：

dim intPntCountSum= 0
(...)
    End If
    intPntCount = intPntCount + 1
    intPntCountSum=intPntCount + 30
Next

最后，如果您不需要调试信息，最好删除这些行：

Debug.Print "Series" & intCptSeries

和

Debug.Print DateDiff("s", startDate, Now)

希望对你有帮助。