EXCELワークシートにおいて数式の参照元の最初のセルおよび参照先の最後のセルを取得する

　数式の参照元セルが多数存在するワークシートを解析しなければならない場合があります．大抵の場合，一つのセルが他のセルの参照元となっていて，かつ別のセルの参照先になっていることが殆どです．参照元の更に参照元を辿って行くと，それ以上は参照元のない最初のセルに行き着きます．今回の記事ではその最初の参照元のセルを探すコードを紹介します．

　2 つの集合が等しいかを確認する方法を用います．ある集合 A と B とが等しいと証明するには，集合 A と集合 B の和と積とをとります．和集合 A ∪ B と積集合 A ∩ B との要素数が等しければ集合 A と集合 B は等しいと言えます．

　比較する対象は Range オブジェクトの DirectPrecedents プロパティと Precedents プロパティです．それぞれセルの直接参照元と参照元全てを取得するプロパティであり，それらが一致すれば参照元が最初のセルとなります．前提条件として他のワークシートへの参照がなく，循環参照を使用していないものとします．

　セルの参照元と参照先を全て繋ぐと木構造になります．最初の参照元，最後の参照先，どちらのルートから辿っても木構造ができます．構成展開で再帰的にノードを展開し，今回作成した関数でリーフか否かを判定します．フォルダや部品表の展開などで一般的に用いられる手法です．

Option Explicit
Sub FirstPrecedents()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim i   As Long
    Dim tmp As Range
    Set Sh1 = ActiveSheet
    Set Sh2 = Worksheets.Add
    Sh2.Name = "TraceFormula"
    i = 1
    For Each tmp In Sh1.UsedRange
        On Error Resume Next
        If Left(tmp.Formula, 1) = "=" Then
            If CheckEqualRange(tmp.DirectPrecedents, tmp.Precedents) Then
                With Sh2
                    .Cells(i, 1) = tmp.Address
                    .Cells(i, 2) = "'" & tmp.Formula
                    .Cells(i, 3) = tmp.DirectPrecedents.Address
                    .Cells(i, 4) = tmp.Precedents.Address
                    .Cells(i, 5) = tmp.DirectPrecedents.Cells.Count
                    .Cells(i, 6) = tmp.Precedents.Cells.Count
                    .Cells(i, 7) = CheckEqualRange(tmp.DirectPrecedents, tmp.Precedents)
                End With
                tmp.DirectPrecedents.Interior.Color = RGB(242, 220, 219)
                i = i + 1
            End If
        End If
        On Error GoTo 0
    Next tmp
End Sub

Function CheckEqualRange(ByRef Rng1 As Range, ByRef Rng2 As Range) As Boolean
    Dim UnionRange      As Range
    Dim IntersectRange  As Range
    Dim tmp             As Range
    CheckEqualRange = False
    Set UnionRange = Application.Union(Rng1, Rng2)
    Set IntersectRange = Application.Intersect(Rng1, Rng2)
    If UnionRange.Cells.Count = IntersectRange.Cells.Count Then
        CheckEqualRange = True
    End If
End Function

　もう一つの方法として，Range オブジェクトの DirectDependents プロパティと DirectPrecedents プロパティを比較する方法もあります．DirectPrecedents プロパティが存在せず，DirectDependents プロパティが存在すればそれはルートであるということです．

Option Explicit
Sub FirstPrecedents2()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim i   As Long
    Dim tmp As Range
    Set Sh1 = ActiveSheet
    Set Sh2 = Worksheets.Add
    Sh2.Name = "Root"
    i = 1
    For Each tmp In Sh1.UsedRange
        On Error Resume Next
        If Left(tmp.Formula, 1) = "=" Then
            If tmp.DirectPrecedents Is Nothing And _
               Not tmp.DirectDependents Is Nothing Then
                Sh2.Cells(i, 1) = tmp.Address
                i = i + 1
            End If
        End If
        On Error GoTo 0
    Next tmp
End Sub

　ついでに参照先の最後のセルを取得するコードも紹介しておきます．条件式の真理値を逆転させるだけです．

Option Explicit
Sub LastDependents()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim i   As Long
    Dim tmp As Range
    Set Sh1 = ActiveSheet
    Set Sh2 = Worksheets.Add
    Sh2.Name = "Leaf"
    i = 1
    For Each tmp In Sh1.UsedRange
        On Error Resume Next
        If Left(tmp.Formula, 1) = "=" Then
            If tmp.DirectDependents Is Nothing And _
                Not tmp.DirectPrecedents Is Nothing Then
                tmp.Interior.Color = RGB(220, 230, 241)
                Sh2.Cells(i, 1) = tmp.Address
                i = i + 1
            End If
        End If
        On Error GoTo 0
    Next tmp
End Sub