实现动态图表渐变效果的代码…_vba xllabelpositionbelow

实现动态图表渐变效果的代码(资料整理子互联网，点击察看原图看动画效果)

 

Sub Chart1Change()
Const OldData As String = "B27:M27"  '<<Change this Range
Const NewData As String = "B28:M28"  '<<Change this Range
Call AnimateChart(OldData, NewData)

'Optional Auto-Adjust Procedure to fix data labels
'For details see:
'http://datapigtechnologies.com/blog/index.php/auto-adjust-chart-label-positions/

Call LabelAdjust(ActiveSheet.ChartObjects("Chart 1").Chart)

End Sub

Function AnimateChart(OldDataSet As String, NewDataSet As String)
Dim NewData As Variant
Dim OldData As Variant
Dim AnimationArray As Variant
Dim OldPoint As Long
Dim NewPoint As Long
Dim x As Integer
Dim i As Integer
Dim p As Double

NewData = ActiveSheet.Range(NewDataSet).Value
OldData = ActiveSheet.Range(OldDataSet).Value
AnimationArray = ActiveSheet.Range(NewDataSet).Value

For i = 1 To 5
    p = 1 / 5 * i
    For x = 1 To WorksheetFunction.Count(NewData)
        OldPoint = OldData(1, x)
        NewPoint = NewData(1, x)
        AnimationArray(1, x) = OldPoint - (OldPoint - NewPoint) * p
    Next x
    Range(OldDataSet).Value = AnimationArray
    DoEvents
Next i
End Function

Function LabelAdjust(TargetChart As Chart)
Dim MaxScale As Long
Dim MinScale As Long
Dim MySeries As Series
Dim MyPoint As Long
Dim PointsArray As Variant
Dim DefaultPosition As Long
Dim AdjustedPosition As Long

'Identify Chart and capture min and max scales
    With TargetChart
    MaxScale = .Axes(xlValue).MaximumScale
    MinScale = .Axes(xlValue).MinimumScale

'Start looping through series
    For Each MySeries In .SeriesCollection

'Exit loop if the series is not a column or line chart
    If MySeries.ChartType <> xlColumnClustered And _
    MySeries.ChartType <> xlLine And _
    MySeries.ChartType <> xlLineMarkers Then
    GoTo SKIPSERIES
    End If

'Trap data points in an array  that can be looped
    PointsArray = MySeries.Values
    For MyPoint = LBound(PointsArray) To UBound(PointsArray)

'Skip the point if no data label
    If MySeries.Points(MyPoint).HasDataLabel = False Then
    GoTo SKIPPOINT
    End If

'Process rules by chart type
        If MySeries.ChartType = xlColumnClustered Then
            MySeries.Points(MyPoint).DataLabel.Position = xlLabelPositionOutsideEnd
            If PointsArray(MyPoint) > MaxScale * 0.9 Then
            MySeries.Points(MyPoint).DataLabel.Position = xlLabelPositionInsideEnd
            End If
        End If
   
        If MySeries.ChartType = xlLine Or MySeries.ChartType = xlLineMarkers Then
        MySeries.Points(MyPoint).DataLabel.Position = xlBelow
            If MyPoint > 1 Then
                If PointsArray(MyPoint) > PointsArray(MyPoint - 1) Then
                MySeries.Points(MyPoint).DataLabel.Position = xlAbove
                Else
                MySeries.Points(MyPoint).DataLabel.Position = xlBelow
                End If
            End If
           
            If PointsArray(MyPoint) > MaxScale * 0.9 Or _
            PointsArray(MyPoint) < MinScale * 1.5 Then
            MySeries.Points(MyPoint).DataLabel.Position = xlRight
            End If
        End If

SKIPPOINT:
    Next MyPoint
SKIPSERIES:
  Next MySeries
 End With

End Function