■散布図のデータ ポイントにラベルを追加する の応用な話です。
まずは Sub pre() でサンプルチャート作成。
#ちょっとややこしい事してるのは、2003 and 2007に対応させるため。サンプルなのであまり気にしない :D
（実行後のサンプル）
作成されたチャートを選択して実行です。
結果はこんな感じ。
まずは Sub pre() でサンプルチャート作成。
#ちょっとややこしい事してるのは、2003 and 2007に対応させるため。サンプルなのであまり気にしない :D
Sub pre()
'サンプルデータシート追加し、２系列バブルチャートを作成
Dim ws As Worksheet
Dim r As Range
Dim s As String
Dim i As Long
Dim v(0 To 4) As String
Set ws = Sheets.Add
s = "'" & ws.Name & "'!"
ws.Range("A1").Value = "a"
ws.Range("A6").Value = "b"
ws.Range("B1:D11").Formula = "=int(rand()*100)"
With ws.ChartObjects.Add(ws.Range("E1").Left, 0, 250, 200).Chart
.HasLegend = False
.ChartType = xlColumnClustered
.SetSourceData ws.Range("B1:C1"), PlotBy:=xlColumns
.ChartType = xlBubble3DEffect
With .SeriesCollection
For i = .Count To 1 Step -1
.Item(i).Delete
Next
v(0) = s & "R1C1"
v(1) = s & "R1C2:R5C2"
v(2) = s & "R1C3:R5C3"
v(3) = 1
v(4) = s & "R1C4:R5C4"
.NewSeries.FormulaR1C1 = "=SERIES(" & Join(v, ",") & ")"
v(0) = s & "R6C1"
v(1) = "(" & s & "R6C2:R9C2," & s & "R11C2)"
v(2) = "(" & s & "R6C3:R9C3," & s & "R11C3)"
v(3) = 2
v(4) = "(" & s & "R6C4:R9C4," & s & "R11C4)"
.NewSeries.FormulaR1C1 = "=SERIES(" & Join(v, ",") & ")"
End With
End With
Set ws = Nothing
End Sub（実行後のサンプル）
作成されたチャートを選択して実行です。
Sub test()
Dim filed() As String
Dim ret() As String
Dim v() As String
Dim s() As String
Dim cnt As Long
Dim cx As Long
Dim ub As Long
Dim n As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim buf
If ActiveChart Is Nothing Then
MsgBox "グラフを選択して実行"
Exit Sub
End If
'項目名セット
filed() = Split("name category_labels values order size")
With ActiveChart
'BubbleChartの時
If (.ChartType = xlBubble) Or (.ChartType = xlBubble3DEffect) Then
cx = 4
Else
cx = 3
End If
'アドレス文字格納配列サイズ決定
cnt = .SeriesCollection.Count
ReDim ret(0 To cnt, 0 To cx) As String
For i = 0 To cx
ret(0, i) = filed(i)
Next
'系列をLoop
For i = 1 To cnt
v = Split(.SeriesCollection(i).Formula, ",")
ub = UBound(v)
'右端の")"を除外
v(ub) = Left$(v(ub), Len(v(ub)) - 1)
'左端の"=SERIES("除外
ret(i, 0) = Mid$(v(0), 9)
n = 1
For j = 1 To cx
'隔範囲のアドレスを考慮
If Left$(v(n), 1) = "(" Then
ReDim s(1 To ub) As String
For k = 1 To ub
s(k) = v(n)
n = n + 1
If Right$(s(k), 1) = ")" Then Exit For
Next
ReDim Preserve s(1 To k)
ret(i, j) = Join(s, ",")
Else
ret(i, j) = v(n)
n = n + 1
End If
Next
buf = Application.Index(ret, i + 1, 0)
MsgBox "系列 " & i & vbLf & vbLf & Join(buf, vbLf)
Next
End With
'新規シートに書き出す時。
'Sheets.Add.Range("A1").Resize(cnt + 1, cx + 1).Value = ret
Erase s
Erase ret
End Sub結果はこんな感じ。
系列 1 name Sheet1!$A$1 category_labels Sheet1!$B$1:$B$5 values Sheet1!$C$1:$C$5 order 1 size Sheet1!$D$1:$D$5 系列 2 name Sheet1!$A$6 category_labels (Sheet1!$B$6:$B$9,Sheet1!$B$11) values (Sheet1!$C$6:$C$9,Sheet1!$C$11) order 2 size (Sheet1!$D$6:$D$9,Sheet1!$D$11)
