February 28, 2014

Excel VBAで折れ線グラフの最大値にデータラベルを設定するには

エクセルのグラフにはデータラベルという機能があり、グラフのプロットに数値を添えて表示することができる。プレゼン資料をイメージしたときに、大抵必要となる開始値、最大値、最小値、直近値のデータラベルを簡単に追加することができるマクロを作ることにする。



使用方法

データラベルを追加したい系列またはグラフを選んでからマクロを実行する。
なお、データラベルの追加位置は、以下の通り。
  • 開始値:下
  • 最大値:上
  • 最小値:下
  • 直近値:上
変更したい場合は、xlLabelpositionXXXXXを変更すればよい。

コード


Sub addDatlabelMax()
    Dim targetSeries As Series
    Select Case TypeName(Selection)
    Case "Series"
        Call subroutineAddDatalabelMax(Selection)
    Case "ChartArea", "PlotArea", "Chart"
        For Each targetSeries In ActiveChart.SeriesCollection
            Call subroutineAddDatalabelMax(targetSeries)
        Next
    End Select
    
End Sub

Sub subroutineAddDatalabelMax(ByRef targetSeries As Series)
    Dim arrayValues As Variant
    Dim maxValue As Variant
    Dim maxPoint As Integer
      
    arrayValues = targetSeries.Values

    maxValue = arrayValues(1)
    maxPoint = 1
    For i = 1 To UBound(arrayValues)
            If (maxValue < arrayValues(i)) Then
                maxValue = arrayValues(i)
                maxPoint = i
            End If
    Next i
  
    With targetSeries.Points(maxPoint)
        .HasDataLabel = True
        With .DataLabel
            .Text = maxValue
            .Position = xlLabelPositionAbove
        End With
    End With
End Sub

Sub addDatlabelMin()
    Dim targetSeries As Series
    Select Case TypeName(Selection)
    Case "Series"
        Call subroutineAddDatalabelMin(Selection)
    Case "ChartArea", "PlotArea", "Chart"
        For Each targetSeries In ActiveChart.SeriesCollection
            Call subroutineAddDatalabelMin(targetSeries)
        Next
    End Select
    
End Sub

Sub subroutineAddDatalabelMin(ByRef targetSeries As Series)
    Dim arrayValues As Variant
    Dim minValue As Variant
    Dim minPoint As Integer
      
    arrayValues = targetSeries.Values

    minValue = arrayValues(1)
    minPoint = 1
    For i = 1 To UBound(arrayValues)
            If (minValue > arrayValues(i)) Then
                minValue = arrayValues(i)
                minPoint = i
            End If
    Next i
  
    With targetSeries.Points(minPoint)
        .HasDataLabel = True
        With .DataLabel
            .Text = minValue
            .Position = xlLabelPositionBelow
        End With
    End With
End Sub

Sub addDatlabelStart()
    Dim targetSeries As Series
    Select Case TypeName(Selection)
    Case "Series"
        Call subroutineAddDatalabelStart(Selection)
    Case "ChartArea", "PlotArea", "Chart"
        For Each targetSeries In ActiveChart.SeriesCollection
            Call subroutineAddDatalabelStart(targetSeries)
        Next
    End Select
    
End Sub

Sub subroutineAddDatalabelStart(ByRef targetSeries As Series)
    With targetSeries.Points(1)
        .HasDataLabel = True
        With .DataLabel
            .Text = targetSeries.Values(1)
            .Position = xlLabelPositionBelow
        End With
    End With
End Sub

Sub addDatlabelEnd()
    Dim targetSeries As Series
    Select Case TypeName(Selection)
    Case "Series"
        Call subroutineAddDatalabelEnd(Selection)
    Case "ChartArea", "PlotArea", "Chart"
        For Each targetSeries In ActiveChart.SeriesCollection
            Call subroutineAddDatalabelEnd(targetSeries)
        Next
    End Select
    
End Sub

Sub subroutineAddDatalabelEnd(ByRef targetSeries As Series)
    With targetSeries.Points(targetSeries.Points.Count)
        .HasDataLabel = True
        With .DataLabel
            .Text = targetSeries.Values(targetSeries.Points.Count)
            .Position = xlLabelPositionAbove
        End With
    End With
End Sub

No comments :

Post a Comment