VBA(excel)でグラフのデータ範囲の取得

Question

excel2010の
VBA利用者です。

グラフが書いてあって（種類は３D等高線グラフ）、
その元になるデータ範囲は
例えば
    ActiveChart.SetSourceData Source:=Range("Sheet1!$A$1:$D$10")
のようにすれば、シート１のRange("A1:D10")の範囲が設定できます。
　では、
　これの　逆に
設定でなくて、取得が出来ませんでしょうか？
　つまり
上記の場合でしたら、範囲"A1:D10"を取得して、変数に代入したいのです。

もし、範囲としての取得が難しいならば、最低限
グラフの現在のデータ範囲の矩形範囲の縦横の、行数、列数の
取得だけでもなんとかしたいのですが、
何か方法はないでしょうか？

縦横数百セルの大き目の範囲を相手にしたいので、
Formulaプロパティで系列ごとに取得していく方法では煩雑になるので
何とかもっと
簡便な方法が無いものかと思っております

御教授のほど、よろしくお願いいたします。

end-u · Accepted Answer

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)
　　　　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)
　　　　　　Debug.Print "系列 " & i, Join(buf, ",")
　　　　Next
　　End With
　　'新規シートに書き出す時。
　　'Sheets.Add.Range("A1").Resize(cnt + 1, cx + 1).Value = ret
　　Erase s, ret
End Sub

こんな感じのは昔書いたことありますが
とにかくデータ範囲をRangeに取得するだけなら
Formula文字列を整理すれば簡単そう。

Sub try2()
　　Dim r As Range

If Not ActiveChart Is Nothing Then
　　　　Call GetChartSourceRange(ActiveChart, r)
　　　　Application.Goto r
　　　　MsgBox r.Address(external:=True)
　　End If
End Sub
'-----------------------------------------------------------
Sub GetChartSourceRange(ByRef c As Chart, ByRef ret As Range)
　　Dim r()　As Range
　　Dim s　　As String
　　Dim n　　As Long
　　Dim i　　As Long

n = c.SeriesCollection.Count
　　ReDim r(1 To n)

For i = 1 To n
　　　　s = Mid$(c.SeriesCollection(i).Formula, 8)
　　　　s = Replace(s, ",,", ",")
　　　　s = Replace(s, "," & i & ",", ",")
　　　　s = Replace(s, "," & i & ")", ")")
　　　　s = "(" & Mid$(s, InStr(s, ",") + 1)
　　　　Set r(i) = Range(s)
　　Next
　　Set ret = r(1)
　　For i = 2 To n
　　　　Set ret = Union(ret, r(i))
　　Next
　　Erase r
End Sub

あらゆるケースに対応できるわけではないですけれども。

keithin · Answer

＞グラフの現在のデータ範囲の矩形範囲

あなたが作成しようとしているグラフは確かに矩形範囲ですが、エクセルでは飛び飛びのセル範囲からも、また系列ごとに個数が違うグラフも描けますので、「全体としての元データ範囲」を取得する方法はありません。

とりあえず簡単には
activechart.seriescollection.count
と
ubound(activechart.seriescollection(1).xvalues)
end sub
といったところと思います。

mitarashi · Answer

残念ながら、
>Formulaプロパティで系列ごとに取得していく方法
です。Range型変数に代入するところはおまけです。
当方も最近、同様の事を思っておりました。もっと簡便な方法があるなら、是非知りたいです。
Sub test()
  Dim mychartObj As ChartObject
  Dim mySeries As Series
  Dim dataRange As Range
  
  Set mychartObj = ActiveSheet.ChartObjects(1)
  For Each mySeries In mychartObj.Chart.SeriesCollection
    Debug.Print Split(Split(mySeries.Formula, ",")(2), "!")(1)
    Set dataRange = Worksheets(Split(Split(mySeries.Formula, ",")(2), "!")(0)).Range(Split(Split(mySeries.Formula, ",")(2), "!")(1))
    Debug.Print dataRange.Parent.Name, dataRange.Address
  Next mySeries
End Sub

縦横の行数の取得なら、上記コードで
 Debug.Print UBound(mySeries.XValues), UBound(mySeries.Values)
でできますが、こういう事で良いのでしょうか。

end-u · Answer

とりあえずActiveChartに対して処理するサンプル。
DataObjectを使う為、VBE-[ツール]-[参照設定]で
「Microsoft Forms 2.0 Object Library」にチェックする必要があります。

Sub try()
　　'■参照設定:Microsoft Forms 2.0 Object Library
　　Dim r As Range

If Not ActiveChart Is Nothing Then
　　　　SendKeys "^c{esc}"
　　　　Application.Dialogs(xlDialogChartSourceData).Show
　　　　On Error Resume Next
　　　　With New DataObject
　　　　　　.GetFromClipboard
　　　　　　Set r = Range(.GetText)
　　　　End With
　　　　On Error GoTo 0
　　　　If Not r Is Nothing Then MsgBox r.Address(external:=True)
　　End If
End Sub

SendKeys使ってますから邪道で危ういし。
それに『データの選択』ダイアログに表示されない複雑なSourceDataの場合は取得できません。

素直に系列をLoopして取得したほうがスマートっぽく見えます。

VBA(excel)でグラフのデータ範囲の取得

Sub test()

＞グラフの現在のデータ範囲の矩形範囲

残念ながら、

とりあえずActiveChartに対して処理するサンプル。

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング