87本目：数式のシート間の依存関係

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

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

出題：数式のシート間の依存関係

#VBA100本ノック 87本目
「相関表」に数式の依存関係を作成してください。
B列のシートの数式が2行目のシートを参照している場合に交点に"○"を入れてください。
※画像参照
セルの数式のみ対象です。
以下は考慮しない。
・INDIRECT関数、串刺し計算、名前定義、条件付き書式、入力規則、文字定数

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

Const ShName相関表 = "相関表"
Const Adrs相関表_左上セル = "B2"

' 100本ノック087：数式のシート間の依存関係
Sub ★数式の依存関係シートを先頭に挿入する()

    Dim wb対象ブック As Workbook: Set wb対象ブック = ActiveWorkbook

    ' すでに相関表シートがあればExit
    If Isシートが存在する(ShName相関表, wb対象ブック) Then
        MsgBox "すでに相関表が存在するブックです。削除してから実行してください。"
        Exit Sub
    End If

    ' 依存関係シート原本の挿入（ノック086）
    Call 数式の依存関係シート原本を指定ブック先頭に挿入する(wb対象ブック)

    ' 依存関係の出力
    Call 数式の依存関係シートへ依存関係を出力する(wb対象ブック)

End Sub

' 依存関係の出力
Sub 数式の依存関係シートへ依存関係を出力する(wb対象ブック As Workbook)

    If Isシートが存在する(ShName相関表, wb対象ブック) = False Then
        MsgBox "相関表シートがブック内にありません。"
        Exit Sub
    End If

    Dim 相関表左上セル As Range
    Set 相関表左上セル = wb対象ブック.Worksheets(ShName相関表).Range(Adrs相関表_左上セル)

    ' 対象ブックの全シート間の参照関係を判定して書き出し
    Dim 数式シートNo As Long, 参照シートNo As Long
    For 数式シートNo = 2 To wb対象ブック.Worksheets.Count
        For 参照シートNo = 2 To wb対象ブック.Worksheets.Count
            If 数式シートNo <> 参照シートNo Then

                ' ■ シート間の参照判定メインロジック
                If Is第1シートが第2シートを参照している(wb対象ブック.Worksheets(数式シートNo) _
                                                                    , wb対象ブック.Worksheets(参照シートNo)) Then
                    相関表左上セル.Cells(数式シートNo, 参照シートNo) = "○"
                End If
                
            End If
        Next
    Next

End Sub

' ■ シート間の参照関係の判定
Function Is第1シートが第2シートを参照している(ws数式シート As Worksheet, ws参照シート As Worksheet) As Boolean
    
    ' シート名!または'シート名'!を検索
    Dim シート参照式 As String: シート参照式 = ws参照シート.Name & "!"
    Dim シート参照式_SQ As String: シート参照式_SQ = "'" & ws参照シート.Name & "'!"
    
    ' 第1シートの数式セル群を取得(なければExit)
    Dim rng数式セル群 As Range
    On Error Resume Next
    Set rng数式セル群 = ws数式シート.UsedRange.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If rng数式セル群 Is Nothing Then Exit Function
    
    ' 数式セル群から参照式があるセルを検索
    Dim 数式セル As Range
    Dim Dic判定済数式リスト As New Dictionary
    For Each 数式セル In rng数式セル群.Cells
        
        ' 新出の数式を判定（後述のEvaluateの処理を軽くすために同じ数式を判定しない）
        If Dic判定済数式リスト.Exists(数式セル.FormulaR1C1) = False Then
    
            ' 数式リストにR1C1形式で登録（これで同じ相対参照の数式は1度しか判定されない）
            Dic判定済数式リスト.Add 数式セル.FormulaR1C1, ""
    
            ' まずシングルクォートありを検索（これはあれば確定）
            If InStr(数式セル.Formula, シート参照式_SQ) > 0 Then
                Is第1シートが第2シートを参照している = True
                Exit Function
            End If
            
            ' シングルクォートなしを検索（これはあってもシート名が後方一致の可能性あり）
            If InStr(数式セル.Formula, シート参照式) > 0 Then
                
                ' シート名!を'シート名'!に変えて数式をEvaluate関数で実行してみる。
                ' 本当に第2シートを参照していれば問題なく動いて同じ値を返す
                ' データ2025! というシートが2025!で引っかかってしまっているだけの場合は、
                ' データ'2025'!という参照式になってしまいエラーとなる
                
                ' Evaluate関数を正しく動かすために数式シートをActiveに
                ws数式シート.Activate
                
                ' 元からエラーが出ている場合は「同じエラーになれば参照あり」
                If IsError(数式セル.Value) Then
                    
                    If 数式セル.Value = Evaluate(Replace(数式セル.Formula, シート参照式, シート参照式_SQ)) Then
                        Is第1シートが第2シートを参照している = True
                        Exit Function
                    End If
                
                ' 元のセルがエラーでない場合は「Evaluateの結果がエラーになっていなければ参照あり」
                Else
                        
                    If IsError(Evaluate(Replace(数式セル.Formula, シート参照式, シート参照式_SQ))) = False Then
                        Is第1シートが第2シートを参照している = True
                        Exit Function
                    End If
                    
                End If

            End If
            
        End If ' 新出の数式を判定
    
    Next ' 数式セル群から参照式があるセルを検索
    
End Function

' 依存関係シート原本の挿入
Sub 数式の依存関係シート原本を指定ブック先頭に挿入する(wb対象ブック As Workbook)

    ' 新規シートを対象ブックの先頭に挿入
    Dim ws出力シート As Worksheet
    Set ws出力シート = wb対象ブック.Worksheets.Add
    ws出力シート.Move before:=wb対象ブック.Worksheets(1)
    ws出力シート.Name = "相関表"

    Dim 相関表左上セル As Range: Set 相関表左上セル = ws出力シート.Range(Adrs相関表_左上セル)

    ' 対象ブックの全シート名を相関表に出力
    Dim シートNo As Long
    For シートNo = 2 To wb対象ブック.Worksheets.Count
    
        相関表左上セル.Cells(シートNo, 1).NumberFormatLocal = "@"
        相関表左上セル.Cells(シートNo, 1) = wb対象ブック.Worksheets(シートNo).Name
        相関表左上セル.Cells(1, シートNo).NumberFormatLocal = "@"
        相関表左上セル.Cells(1, シートNo) = wb対象ブック.Worksheets(シートNo).Name

    Next
    
    ' 各種書式設定
    Dim 相関表エリア As Range: Set 相関表エリア = 相関表左上セル.CurrentRegion
    
    ' 文字のセンタリング
    相関表エリア.HorizontalAlignment = xlCenter
    相関表エリア.VerticalAlignment = xlCenter
    
    ' 格子罫線
    相関表エリア.Borders.LineStyle = xlContinuous

    ' 斜め罫線
    Dim i As Long
    For i = 1 To 相関表エリア.Rows.Count
        相関表エリア.Cells(i, i).Borders(xlDiagonalDown).LineStyle = xlContinuous
    Next
    
    ' 列幅（全シートがある第1列をAutoFitして全列へ反映
    相関表エリア.Cells(1, 1).EntireColumn.AutoFit
    相関表エリア.EntireColumn.ColumnWidth = 相関表エリア.Cells(1, 1).EntireColumn.ColumnWidth

End Sub

汎用関数モジュール

Option Explicit

' シートの存在判定
' 参考：https://www.limecode.jp/entry/utility/existsworksheet
Function Isシートが存在する(判定シート名 As String, 指定ブック As Workbook) As Boolean

    ' ブック内の全シートを走査
    Dim ws As Worksheet
    For Each ws In 指定ブック.Worksheets

        ' シート名が一致したらTrueを返してExit
        If ws.Name = 判定シート名 Then
            Isシートが存在する = True
            Exit Function
        End If

    Next

End Function

解説

全シート間の数式参照関係を総当たりで調べるマクロです。

こういったループが複雑になりそうなマクロは、

Function Is第1シートが第2シートを参照している(ws数式シート As Worksheet, ws参照シート As Worksheet) As Boolean

このような「2つのWorksheet間の関係を判定してくれる関数」を作ることで、

• 全シートを総当たりループするコード
• 2シート間の全数式をループするコード

を分離することができ、マクロの設計がやりやすくなります。

プロシージャ分割の基本ですのでおさえておきましょう。

さて、肝心の「シート間に参照があるか」の判定ですが、
参照先のセルを調べるPrecedents/Dependentsプロパティは、
残念ながら他シートの参照先取得には対応していません。

よって「シート名!A1」のテキストを愚直に調べる必要があります。

判定時には

• シート名に()などが入っている場合はシングルクォーテーションが入ること
• 2025!がヒットしてもデータ2025!が後方一致ヒットしただけかもしれないこと

に注意しなければいけないため、結構面倒なコードになりますね。

これらに対応するために、

1. まずは「'シート名'!」で探し、あればその時点で確定
2. 続いて「シート名!」で探し、あれば以下の判定に進む
3. 「シート名!」を「'シート名'!」に置換してエラーにならないかチェック

という手順を踏んでいます。

また、3番の判定を行う際に数式を再度実行してしまうため、
処理が重くならないよう、ひとつの数式につき1回しか判定しないようにしました。

FormulaR1C1形式にすればコピペした数式がすべて同じ式になりますので、
それをDictionaryのKeyにいれて重複判定をかけています。

実用する場合はここまでのコードにはしなくてもいいと思います。

シート名の後方一致はあきらめたり、
高速化は遅くて困ってから考えたり、
コーディングコストと相談してどこまで実装するか決めてください。