https://www.limecode.jp/entry/fungo/079-extend-chart-data-range

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：グラフのデータ範囲拡張

#VBA100本ノック 78本目
シートには複数のグラフがあります。
シートの全グラフのデータの範囲を一括で変更します。
データ範囲の下に追加された行をグラフのデータ範囲に追加してください。
※画像では2021/01を追加（B1:C10をB1:C11）します。
※シートは任意

データ拡張対象グラフ

◇ 出題ページはこちら

ソースコード

メインモジュール

' 100本ノック078：グラフのデータ範囲拡張
Sub すべてのグラフのデータ範囲を自動拡張する()
    Dim ws対象シート As Worksheet: Set ws対象シート = ActiveSheet

    ' すべてのグラフをループ
    Dim グラフ As ChartObject
    For Each グラフ In ws対象シート.ChartObjects
        
        ' グラフ内のすべての系列をループ
        Dim 各系列 As Series
        For Each 各系列 In グラフ.Chart.SeriesCollection
        
            ' 系列の参照数式を取得（↓こんな式が入ってます）
            ' =SERIES(Sheet1!$C$1,Sheet1!$B$2:$B$10,Sheet1!$C$2:$C$10,1)
            Dim 系列参照数式 As String: 系列参照数式 = 各系列.Formula
        
            ' =SERIES(○○)の○○だけを抜き出し
            系列参照数式 = Leftからn文字削除(系列参照数式, Len("=SERIES("))
            系列参照数式 = Rightからn文字削除(系列参照数式, 1)
        
            ' 数式をカンマごとに区切って各要素をループ
            Dim Arr系列内の参照リスト: Arr系列内の参照リスト = Split(系列参照数式, ",")
            Dim i As Long
            For i = 0 To UBound(Arr系列内の参照リスト)
                Dim 参照式 As String: 参照式 = Arr系列内の参照リスト(i)
                
                ' 単独セル(グラフ見出し)や設定値以外のセル範囲を処理
                If IsNumeric(参照式) = False Then
                    Dim 参照範囲 As Range: Set 参照範囲 = Range(参照式)
                    If 参照範囲.Cells.Count > 1 Then
                        
                        ' 各参照式を値が入っているセルまでそれぞれ拡張
                        Set 参照範囲 = GetRange対象範囲を値が続く限り拡張する(参照範囲)
                        Arr系列内の参照リスト(i) = 参照範囲.Address(External:=True)
                        
                    End If
                End If
                
            Next
            
            ' =SERIESの形に戻して系列の参照式に代入
            系列参照数式 = "=SERIES(" & Join(Arr系列内の参照リスト, ",") & ")"
            各系列.Formula = 系列参照数式
            
        Next ' グラフ内のすべての系列をループ
        
    Next ' すべてのグラフをループ

End Sub

汎用関数モジュール

' データ範囲の自動拡張
Function GetRange対象範囲を値が続く限り拡張する(元範囲 As Range) As Range

    Dim 結果範囲 As Range: Set 結果範囲 = 元範囲
    Dim 拡張候補 As Range
    Do
        
        Set 拡張候補 = 結果範囲.Rows(結果範囲.Rows.Count + 1)
                
        If Fx.CountIf(拡張候補, "<>") > 0 Then
            Set 結果範囲 = Union(結果範囲, 拡張候補)
        Else
            Set GetRange対象範囲を値が続く限り拡張する = 結果範囲
            Exit Do
        End If
        
    Loop

End Function

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 文字列の前後を削除
Function Leftからn文字削除(ByVal 元テキスト As String, n As Long) As String
    Leftからn文字削除 = Mid(元テキスト, n + 1)
End Function
Function Rightからn文字削除(ByVal 元テキスト As String, n As Long) As String
    If Len(元テキスト) - n > 0 Then
        Rightからn文字削除 = Left(元テキスト, Len(元テキスト) - n)
    End If
End Function