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

Question

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

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

我的问题是我的编辑很慢，我已经阅读了很多关于 VBA 优化的内容，但没有完成我为每条曲线测量 20 秒的技巧，这对于我的层次结构来说是“不可接受的”。 我正在考虑多线程，但它的工作量太大了，但收益如此之小（%4？或 %8？）

(FYI 积分计算等都是在开表前完成的，效果很好)

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

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)

我希望它有所帮助。