■散布図のデータ ポイントにラベルを追加する の応用な話です。
まずは Sub pre() でサンプルチャート作成。
#ちょっとややこしい事してるのは、2003 and 2007に対応させるため。サンプルなのであまり気にしない :D
(実行後のサンプル)
作成されたチャートを選択して実行です。
結果はこんな感じ。
まずは Sub pre() でサンプルチャート作成。
#ちょっとややこしい事してるのは、2003 and 2007に対応させるため。サンプルなのであまり気にしない :D
Sub pre() 'サンプルデータシート追加し、2系列バブルチャートを作成 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)