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

2023年8月16日 13:53

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

応援してやろうということで、お気持ちをいただければ嬉しいです。もっと勉強したり、調べたりする糧にしたいと思います。