'散布図グラフ用リンクデータラベル追加マクロ

'グラフまたはデータ系列を選択して実行してください。

Option Explicit

Sub DataLableAdd()
    Const sAppName As String = "リンクデータラベルの追加"
    Dim oSeries As Series
    Dim oRange As Range
    Dim r As Range
    Dim sText As String
    Dim bLink As Boolean
    Dim iPoints As Integer
    Dim iRet As Integer
    Dim i As Integer

    On Error GoTo ErrorHandler

    sText = "データラベルに設定するセル範囲を選択してください。" _
        & Chr$(10) & "範囲には見出しを含めないでください。"

    If TypeName(Selection) = "Series" Then
        Set oSeries = Selection
    Else
        Set oSeries = Nothing
        On Error Resume Next
        Set oSeries = ActiveChart.SeriesCollection(1)
        On Error GoTo ErrorHandler
        If oSeries Is Nothing Then
            MsgBox "グラフまたはデータ系列を選択してください。", _
                vbExclamation, sAppName
            Exit Sub
        End If
        sText = "1番目のデータ系列にデータラベルを追加します。" & _
            Chr$(10) & sText
    End If

    Select Case ActiveWindow.Type
        Case xlChartInPlace, xlChartAsWindow
            ActiveWindow.Visible = False
    End Select

    Set oRange = InputBoxRange(sText, sAppName, "")
    If oRange Is Nothing Then
        Exit Sub
    End If

    '複数セル範囲選択を有効にするには、以下の1行をコメントにしてください。
    'ただし、実行後必ずデータの正しさを目で確認してください。
    Set oRange = oRange.Areas(1)

    If oRange.Cells.Count = 1 Then
        If oRange.EntireRow.Hidden Or oRange.EntireColumn.Hidden Then
            Exit Sub
        End If
    Else
        Set oRange = oRange.SpecialCells(xlVisible)
    End If

    iRet = MsgBox("データラベルをセルにリンクさせますか?", _
        vbQuestion Or vbYesNoCancel, sAppName)
    If iRet = vbCancel Then
        Exit Sub
    End If
    bLink = (iRet = vbYes)

    Application.ScreenUpdating = False

    oSeries.ApplyDataLabels Type:=xlShowLabel
    iPoints = oSeries.Points.Count

    i = 1
    For Each r In oRange.Cells
        If bLink Then
            sText = "=" & r.Address(ReferenceStyle:=xlR1C1, external:=True)
        Else
            sText = CStr(r.Value)
        End If
        oSeries.Points(i).DataLabel.Text = sText
        i = i + 1
        If i > iPoints Then
            Exit For
        End If
    Next
    For i = oRange.Cells.Count + 1 To iPoints
        oSeries.Points(i).DataLabel.Text = " "
    Next

    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, sAppName
End Sub

'セル範囲を入力する関数
Function InputBoxRange(sPrompt As String, sTitle As String, _
        sDefault As String) As Range
    On Error Resume Next
    Set InputBoxRange = Application.InputBox( _
        prompt:=sPrompt, title:=sTitle, default:=sDefault, Type:=8)
End Function