散布図にラベルを追加するマクロ

散布図のポイントにラベルを追加したい

Excelで散布図をかいたときにポイントにラベルを追加したいんですがなかなかうまくいかないので思い悩んだあげくVBAで解決したので、その際のスクリプトをかいたので公開しておきます。
方法を調べていったら、斜めにデータを配置するのがオーソドックスなやりかたみたいですね。ttp://pc.nikkeibp.co.jp/article/NPC/20060628/242035/

使い方と前提条件

マクロ実行時に「セル名を入力を促すダイアログ」が出てきますが、そのときはラベル名の一番最初のセル名を入力してください。この例では、B3を指定するとラベルが自動的に振られます。条件としてテーブルのフォーマットはサンプルのような{ラベル名,X,Y},{ラベル名,Y,X}とかそういう表を前提としています。

マクロ実行前

マクロ実行後


ソースコード*1

Public Sub 散布図にラベルを追加する()
    AttachLabelsToPoint
End Sub

Private Function AttachLabelsToPoint(Optional labels As range = Nothing)

	Dim i As Integer, j As Integer

    If (ActiveChart Is Nothing) Then
        MsgBox ("アクティブなグラフはありません。" & Chr(10) & Chr(13) & "ラベルを追加するグラフを選んでください。")
        Exit Function
    End If

    ' ラベル開始セルの指定
    If (labels Is Nothing) Then
        On Error Resume Next
            Set labels = Application.InputBox(Prompt:="ラベル開始セル名を入力してください。例)A1", Type:=8)
            If (Err.Number <> 0) Then
                Exit Function
            End If
        On Error GoTo 0
    End If

    ' スクリーンの更新をOFF
    Application.ScreenUpdating = False

    ' ラベルの記入処理
    For i = 1 To ActiveChart.SeriesCollection.Count
        For j = 1 To ActiveChart.SeriesCollection(i).points.Count
            ActiveChart.SeriesCollection(i).points(j).HasDataLabel = True
            ActiveChart.SeriesCollection(i).points(j).DataLabel.Text = labels.Offset(j - 1, 0).Value
        Next j
    Next i

End Function

追記

*1:にわかVBAerなので突っ込み歓迎