■VBAでグラフの元データ範囲を取得

■散布図のデータ ポイントにラベルを追加する の応用な話です。

まずは 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)