VBA(Excel)でグラフのデータ範囲の取得
ExcelのVBAでのチャートの操作について、次のようなことがしたい場合があります。
１．チャートに別のデータ範囲を設定したい
２．チャートのデータ範囲を取得したい
１．のチャートに別のデータ範囲を設定したい場合は、
ActiveChart.SetSourceData Source:=Range(cells(1,1), Cells(20,3)のような感じで設定できます。ネットで検索するとこれについての記事はたくさんあります。
２．のチャートのデータ範囲を取得したい場合は、良い方法がないのか、あまり知られていません。あまりスマートなやり方ではありませんが以下に作成したVBAを示します。
チャートに設定されているデータ範囲は、チャートオブジェクトのシリーズコレクションのフォーミュラプロパティー(Chart.SeriesCollection.Formula）にあり、その値は例えば =SERIES(Sheet1!$D$3,Sheet1!$B$10:$B$20,Sheet1!$D$10:$D$20,2)
のような形式の文字列です。
ここから$D$3や$B$10:$B$20を検索して取り出すことにします。検索は正規表現を用いました。ヒットする件数はチャートによるので結果はDictionaryに入れて返します。
ソースコード
１．チャートに別のデータ範囲を設定したい
シートに設定したい行を入力するセルを作り、その値を読み取ってチャートの範囲を変更します。
Public Sub データの範囲を設定する()
'開始行、終了行を取得する
Dim rowS As Integer
Dim rowE As Integer
rowS = Cells(17, "G")
rowE = Cells(18, "G")
'チャートの範囲を決定する
'タイトルの範囲:Range(Cells(3, "B"), Cells(3, "D"))
'データの範囲:Range(Cells(rowS, "B"), Cells(rowE, "D"))
Dim rng As Range
Set rng = Union(Range(Cells(3, "B"), Cells(3, "D")), Range(Cells(rowS, "B"), Cells(rowE, "D")))
'チャートに範囲を設定する
Dim cht As Chart
Set cht = ActiveSheet.ChartObjects(1).Chart 'アクティブなシートにある１つ目のチャート
cht.SetSourceData Source:=rng
End Sub２．チャートのデータ範囲を取得したい
アクティブなシートにある１つ目のチャートを対象にして、シリーズコレクションを取得し、そのフォーミュラからアドレス文字を検索をし、Dictionaryに保存します。
アドレスは単独セルアドレスと範囲アドレスに分けて検索します。
Dictionaryキーは、通し番号-単独/範囲番号-連番 としてあります（深い意味はありません）。
Public Sub データの範囲を取得する()
Dim cht As Chart
Set cht = ActiveSheet.ChartObjects(1).Chart 'アクティブなシートにある１つ目のチャート
' Set cht = ActiveChart'アクティブなチャート
'チャートのシリーズコレクション
Dim sc As SeriesCollection
Set sc = cht.SeriesCollection
'設定されている内容
Dim scf As Variant
scf = GetSCFormula(sc)
'アドレスを取得
Dim dic As Dictionary
Set dic = GetAddress(scf)
'アドレス取得結果を表示
Dim msg As String
msg = ""
Dim keywd As Variant
For Each keywd In dic.Keys
msg = msg & keywd & " : " & dic(keywd) & vbCrLf
Next
Dim uf As New UserForm1
uf.TextBox1.Text = msg
uf.Show
'=Sheet1!$B$3:$D$3,Sheet1!$B$10:$D$20
End Sub
'SeriesCollectionに設定されている内容
Private Function GetSCFormula(sc As SeriesCollection) As Variant
Dim scf As Variant
ReDim scf(sc.Count)
Dim i As Integer
For i = 1 To sc.Count
scf(i) = sc(i).Formula
Next
GetSCFormula = scf
End Function
Private Function GetAddress(scf As Variant) As Dictionary
Dim re As New RegExp '正規表現で検索する
Dim mchs As MatchCollection '正規表現の検索結果
Dim dic As New Dictionary '結果を保存する辞書
With re
.Global = True
Dim iscf As Integer
Dim imchs As Integer
Dim isub As Integer
Dim keywd As Variant
For iscf = 1 To UBound(scf)
'単独のアドレスを取得する
.Pattern = "!(\$[A-Z]+?\$[0-9]+?)," '単独のアドレス
Set mchs = .Execute(scf(iscf))
If mchs.Count > 0 Then
For imchs = 0 To mchs.Count - 1
For isub = 0 To mchs(imchs).SubMatches.Count - 1
keywd = dic.Count & "-" & imchs & "-" & isub
dic(keywd) = mchs(imchs).SubMatches(isub)
Next
Next
End If
'範囲のアドレスを取得する
.Pattern = "(\$[A-Z]+?\$[0-9]+?:\$[A-Z]+?\$[0-9]+?)," '範囲のアドレス
Set mchs = .Execute(scf(iscf))
If mchs.Count > 0 Then
For imchs = 0 To mchs.Count - 1
For isub = 0 To mchs(imchs).SubMatches.Count - 1
keywd = dic.Count & "-" & imchs & "-" & isub
dic(keywd) = mchs(imchs).SubMatches(isub)
Next
Next
End If
Next
End With
Set GetAddress = dic
End Functionシリーズコレクションのフォーミュラが以下であれば
=SERIES(Sheet1!$D$3,Sheet1!$B$10:$B$20,Sheet1!$D$10:$D$20,2)
=SERIES(Sheet1!$C$3,Sheet1!$B$10:$B$20,Sheet1!$C$10:$C$20,1)次のような結果が得られます。
0-0-0 : $C$3
1-0-0 : $B$10:$B$20
2-1-0 : $C$10:$C$20
3-0-0 : $D$3
4-0-0 : $B$10:$B$20
5-1-0 : $D$10:$D$20なお、正規表現と連想記憶を使うために、次の二つを参照設定しています。
Microsoft VBScript Reguler Expression 5.5
Microsoft Scripting Runtime
作成したExcelは以下です。
#Excel , #VBA , #Chart , #SeriesCollection
いいなと思ったら応援しよう！
