【グラフにラベルを付ける】【エクセル,VBA,グラフ】

折れ線グラフが複数ある場合、凡例を普通に配置しても、似たような色の線が必ず存在するので系列名とどの折れ線が対応するかわかりにくいです。

例えば以下のグラフは1920年～2000年の県別の人口推移ですが何が何だかわかりません。

県別人口推移

見やすくするためによく使われる方法としては、終点にラベルを表示して系列名を表示します。またラベルの色は折れ線に合わせて変更し、重ならないようにずらします。以下の通り。手作業でやろうとすると大変なので、VBAで自動化してみました。

県別人口推移

コードを実行するまでの流れは以下の通りです。

1.適当に折れ線グラフを作る（グラフ→散布図→直線）
2.グラフをアクティブ（選択）にする。
3.コードを実行する。（アクティブチャートに対して処理します。）

Rank関数は以下を参考に。
dukicco.hatenadiary.jp

Sub グラフに色付きで系列名のラベルをはる()

Dim i As Long, j As Long, k As Long, l As Long, m As Long, arr As Variant, arr1 As Variant, tst As String
Dim tsingle1 As Single
    
    'まずはチャートを選択しておく
    
    '系列名を表示するスペースを確保
    'プロットエリア（内）の幅を取得
    tsig = ActiveChart.PlotArea.Width
    'グラフエリア（外）の幅を設定。内側+200
    tst = ActiveChart.Parent.Name
    ActiveSheet.Shapes(tst).Width = tsig + 250
    ActiveChart.PlotArea.Width = tsig

   '各系列の最終データの数値を取得し配列に格納
    ReDim arr1(1 To ActiveChart.SeriesCollection.Count)
    For i = 1 To ActiveChart.SeriesCollection.Count
        arr = ActiveChart.SeriesCollection(i).Values
        arr1(i) = arr(UBound(arr))
    Next
    
    '各系列をループ
    For i = 1 To ActiveChart.SeriesCollection.Count
        'ActiveChart.SeriesCollection(i).Select
        arr = ActiveChart.SeriesCollection(i).Values
            
            '各系列のデータ数を取得。一番最後のデータにラベルを表示する。kを1にすると一番左のデータにラベルされる。
            k = UBound(arr)
            ActiveChart.SeriesCollection(i).Points(k).ApplyDataLabels
            '各系列の系列名を取得
            tst = ActiveChart.SeriesCollection(i).Name
            On Error Resume Next
            'ラベルの表示を値から系列名に変更
            ActiveChart.SeriesCollection(i).DataLabels(k).Format.TextFrame2.TextRange.InsertAfter tst
            'ラベルの位置を取得
            tsingle1 = ActiveChart.SeriesCollection(i).DataLabels(k).Left
            '系列の最終データの値の順位を取得。
            m = Rank関数降順(arr1, i)
            'ラベルを順位に応じずらしていく。上から５つずらしたら元の位置に戻す。
            ActiveChart.SeriesCollection(i).DataLabels(k).Left = ((m - 1) Mod 5) * 40 + tsingle1
            '系列折れ線のカラープロパティを取得
            j = ActiveChart.SeriesCollection(i).Format.Line.ForeColor.RGB
            '系列名の文字数を取得
            l = Len(tst)
            'ラベルの色を折れ線の色に変更。フォントサイズを10。太字。
            ActiveChart.SeriesCollection(i).DataLabels(k).Format.TextFrame2.TextRange.Characters(1, l).Font.Fill.ForeColor.RGB = j
            ActiveChart.SeriesCollection(i).DataLabels(k).Format.TextFrame2.TextRange.Characters(1, l).Font.Size = 10
            ActiveChart.SeriesCollection(i).DataLabels(k).Format.TextFrame2.TextRange.Characters(1, l).Font.Bold = msoTrue
    Next

End Sub
Function Rank関数降順(arr As Variant, j As Long) As Long
'渡された配列内の順位を返します。
Dim i As Long

For i = 1 To UBound(arr)
    If arr(j) = WorksheetFunction.Large(arr, i) Then
        Rank関数降順 = i
        Exit For
    End If
Next

End Function