Excel
VBA
ExcelVBA

参照先を詳細にみるユーザーフォームを作る

トレース機能の貧弱さ

  • 参照先の確認は、「参照先のトレース」または「参照先へジャンプ」で行える
  • 一方、他シートを参照していると挙動が怪しいなど、不便な点が多い
  • また、参照先の参照先を見たりしていると、もとのセルに戻れなくなる

VBAを使った改善案 - マクロの要件

  • 参照先の参照先の参照先・・・ を確認できるようにする
  • 元のセルに戻れるようにする
  • セルを選択して起動すれば、あとはフォーム内の操作で完結できるようにする

マクロの全体像

選択中のセルの参照先をリストアップする

選択中のRangeオブジェクトに対して、Precedentsプロパティを使用したくなるところですが、Precendetsプロパティは他シートを参照できません。

次は、NavigateArrowメソッドを使うという手が考えられます。こちらは、他シートを参照することもできます。

しかしながら、NavigateArrowは、元のセルに近い順に参照先をリストアップしてしまうので、数式を確認するという用途では使いづらいと言えます。

したがって、数式の文字列を直接抽出するという方法をとるしかありません。

ユーザーフォームに並べる

抽出した参照先の配列をユーザーフォームに並べます。

ListBoxオブジェクトのListプロパティに入れるだけです。

セルを選択する

これが少し厄介になります。Selectメソッドは、実はシートをまたぐことができません。

同じように、Rangeオブジェクトの引数にシート名を入れることはできませんし、参照先には名前が使われることもあります。

要するに、Range("Sheet1!A1").Select を行えるようなマクロを組む必要があります。

再度参照先をリストアップする

参照先の参照先を参照するためには、最初に戻れなくてはなりません。

これを何段階か行える仕組みをユーザーフォームで実現する必要があります。

サンプルコード

参照先をカンマ区切りで取得する

参照先かどうかを直接的に判断することはできませんから、配列化して確認します。

配列化に使うSplit関数は、複数の区切り文字をしていることができません。このため、まずは四則演算の記号や()をあらかじめカンマ(カンマ以外でもよい)に置き換えます。

あとは、配列の要素が A1 のような恰好をしているかを判定します。ここが力業になってしまいますが、よほど特殊な書き方をしていない限り、!, &, : の3記号を含む要素はセルアドレスです。それらを含まないもののうち、アルファベット&数字型の要素もアドレスでしょう。

Function Precedents_Csv(r_argument As Range) As String

    Dim address_csv As String
    address_csv = ""

    '===============================
    ' r_argument is not a cell
    '===============================
    Dim r As Range
    If r_argument.Count >= 2 Then
        For Each r In r_argument
            address_csv = address_csv & "," & r.Parent.Name & "!" & r.Address
        Next r
        Precedents_Csv = Mid(address_csv, 2)
        Exit Function
    End If

    '===============================
    ' r_argument hasn't got formula
    '===============================
    If r_argument.HasFormula = False Then
        Precedents_Csv = r_argument.Value
        Exit Function
    End If

    '===============================
    ' r_argument is a cell
    '===============================
    Dim all_array As Variant
    Dim i As Integer
    Dim address_of_element As String

    all_array = Split(Replace_Symbols(r_argument.Formula), ",")

    For i = 0 To UBound(all_array)
        Select Case Type_Of_Address(all_array(i))
        Case 0 ' Address with "!"
            address_csv = address_csv & "," & all_array(i)
        Case 1 ' Address without "!"
            address_csv = address_csv & "," & r_argument.Parent.Name & "!" & all_array(i)
        Case 2 ' Non Address
            address_of_element = ""
        End Select
    Next i

    Precedents_Csv = Mid(address_csv, 2)

End Function

Function Replace_Symbols(target_formula As String) As String

    Dim tmp As String
    tmp = target_formula
    tmp = Replace(tmp, "+", ",")
    tmp = Replace(tmp, "-", ",")
    tmp = Replace(tmp, "*", ",")
    tmp = Replace(tmp, "/", ",")
    tmp = Replace(tmp, "^", ",")
    tmp = Replace(tmp, "&", ",")
    tmp = Replace(tmp, "=", ",")
    tmp = Replace(tmp, ">", ",")
    tmp = Replace(tmp, "<", ",")
    tmp = Replace(tmp, "(", ",")
    tmp = Replace(tmp, ")", ",")

    Replace_Symbols = tmp

End Function

Function Type_Of_Address(test_string As Variant) As Integer

    ' Declaration
    Dim addresses(1 To 21)
    Dim alp As String
    Dim num As String
    alp = "[A-Z]"
    num = "[0-9]"

    addresses(1) = alp & num
    addresses(2) = alp & num & num
    addresses(3) = alp & num & num & num
    addresses(4) = alp & num & num & num & num
    addresses(5) = alp & num & num & num & num & num
    addresses(6) = alp & num & num & num & num & num & num
    addresses(7) = alp & num & num & num & num & num & num & num

    addresses(8) = alp & alp & num
    addresses(9) = alp & alp & num & num
    addresses(10) = alp & alp & num & num & num
    addresses(11) = alp & alp & num & num & num & num
    addresses(12) = alp & alp & num & num & num & num & num
    addresses(13) = alp & alp & num & num & num & num & num & num
    addresses(14) = alp & alp & num & num & num & num & num & num & num

    addresses(15) = alp & alp & alp & num
    addresses(16) = alp & alp & alp & num & num
    addresses(17) = alp & alp & alp & num & num & num
    addresses(18) = alp & alp & alp & num & num & num & num
    addresses(19) = alp & alp & alp & num & num & num & num & num
    addresses(20) = alp & alp & alp & num & num & num & num & num & num
    addresses(21) = alp & alp & alp & num & num & num & num & num & num & num

    '===============================
    ' Is Name
    '===============================
    Dim n As Name
    For Each n In Names
        If test_string = n.Name Then
            test_string = Mid(n.RefersTo, 2)
            Type_Of_Address = 0
            Exit Function
        End If
    Next n

    '===============================
    ' Has Specific Symbol
    '===============================
    If test_string Like "*!*" Then
        Type_Of_Address = 0
        Exit Function
    ElseIf test_string Like "*$*" Or test_string Like "*:*" Then
        Type_Of_Address = 1
        Exit Function
    End If

    '===============================
    ' Is [A-Z] & [0-9] Type
    '===============================
    Dim i As Integer
    For i = 1 To 21
        If test_string Like addresses(i) Then
            Type_Of_Address = 1
            Exit Function
        End If
    Next i

    '===============================
    ' Others: Is not an address
    '===============================
    Type_Of_Address = 2

End Function

アクティブでないシートのセルの選択と取得

Sub Flex_Select(address_argument As String)
' Select range in nonactive worksheet
    On Error Resume Next
    Worksheets(Split(address_argument, "!")(0)).Activate
    Range(Split(address_argument, "!")(1)).Select
End Sub

Function Address_To_Range(address_argument As String) As 
' Get range in nonactive worksheet
    On Error Resume 

    ' Convert Name to Address
    Dim n As Name
    For Each n In Names
        If address_argument = n.Name Then
            address_argument = Mid(n.RefersTo, 2)
            Exit For
        End If
    Next 

    ' Set Range
    Dim ws As Worksheet
    Set ws = Worksheets(Split(address_argument, "!")(0))
    Set Address_To_Range = ws.Range(Split(address_argument, "!")(
End Function

ユーザーフォームの設計

フォーム

image.png

コード

Option Explicit

Private Sub Label8_Click()
    With UFM_TRACE
        Flex_Select .Label8.Caption
        .ListBox1.SetFocus
        .ListBox2.Clear
        .ListBox3.Clear
        .ListBox4.Clear
        .ListBox5.Clear
    End With
End Sub

Private Sub CommandButton1_Click()
    With UFM_TRACE
        Flex_Select .Label8.Caption
        .ListBox1.SetFocus
        .ListBox2.Clear
        .ListBox3.Clear
        .ListBox4.Clear
        .ListBox5.Clear
    End With
End Sub

Private Sub CommandButton2_Click()

    Dim previous_lbox As Object
    Dim current_lbox As Object

    With UFM_TRACE

        .TextBox2.Value = ""

        If .ListBox5.ListCount > 0 Then
            Set current_lbox = .ListBox5
            Set previous_lbox = .ListBox4
        ElseIf .ListBox4.ListCount > 0 Then
            Set current_lbox = .ListBox4
            Set previous_lbox = .ListBox3
        ElseIf .ListBox3.ListCount > 0 Then
            Set current_lbox = .ListBox3
            Set previous_lbox = .ListBox2
        Else
            Set current_lbox = .ListBox2
            Set previous_lbox = .ListBox1
        End If

    End With

    current_lbox.Clear
    previous_lbox.SetFocus

End Sub

Private Sub CommandButton3_Click()

    Dim next_lbox As Object
    Dim current_lbox As Object

    With UFM_TRACE

        If .ListBox2.ListCount = 0 Then
            Set current_lbox = .ListBox1
            Set next_lbox = .ListBox2
        ElseIf .ListBox3.ListCount = 0 Then
            Set current_lbox = .ListBox2
            Set next_lbox = .ListBox3
        ElseIf .ListBox4.ListCount = 0 Then
            Set current_lbox = .ListBox3
            Set next_lbox = .ListBox4
        Else
            Set current_lbox = .ListBox4
            Set next_lbox = .ListBox5
        End If
    End With

    With current_lbox
        Update_Formulabox .List(.ListIndex)
    End With

    Dim precedents_arr As Variant
    With current_lbox
        precedents_arr = Split(Precedents_Csv(Address_To_Range(.List(.ListIndex))), ",")
    End With

    Update_Listbox next_lbox, precedents_arr
    next_lbox.SetFocus

End Sub

Private Sub CommandButton4_Click()
    Unload UFM_TRACE
End Sub

Private Sub ListBox1_Change()
    Change_Listbox UFM_TRACE.ListBox1
End Sub

Private Sub ListBox2_Change()
    Change_Listbox UFM_TRACE.ListBox2
End Sub

Private Sub ListBox3_Change()
    Change_Listbox UFM_TRACE.ListBox3
End Sub

Private Sub ListBox4_Change()
    Change_Listbox UFM_TRACE.ListBox4
End Sub

Private Sub ListBox5_Change()
    Change_Listbox UFM_TRACE.ListBox5
End Sub

Private Sub UserForm_Initialize()

    With UFM_TRACE

        .StartUpPosition = 2
        .Width = 570
        .Height = 340
        .Caption = "Precedent Tracer"

        ' Original Formula
        With .Label1
            .Top = 10: .Left = 10: .Width = 200: .Height = 15
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Original Formula"
        End With
        With .TextBox1
            .Top = 25: .Left = 10: .Width = 540: .Height = 20
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .Text = Selection.Formula
        End With

        ' Current Formula
        With .Label2
            .Top = 55: .Left = 10: .Width = 200: .Height = 15
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Current Formula/Value"
        End With
        With .TextBox2
            .Top = 70: .Left = 10: .Width = 540: .Height = 20
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
        End With

        ' Labels
        With .Label3
            .Top = 100: .Width = 100: .Height = 15
            .Left = 10
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Precedents 1"
        End With
        With .Label4
            .Top = 100: .Width = 100: .Height = 15
            .Left = 120
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Precedents 2"
        End With
        With .Label5
            .Top = 100: .Width = 100: .Height = 15
            .Left = 230
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Precedents 3"
        End With
        With .Label6
            .Top = 100: .Width = 100: .Height = 15
            .Left = 340
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Precedents 4"
        End With
        With .Label7
            .Top = 100: .Width = 100: .Height = 15
            .Left = 450
            .Font.Size = 8: .Font.Bold = True
            .Caption = "Precedents 5"
        End With

        ' List Boxes
        With .ListBox1
            .Top = 115: .Width = 100: .Height = 150
            .Left = 10
            .Font.Size = 10
            .TabStop = False
            .SpecialEffect = fmSpecialEffectEtched
            .SetFocus
        End With
        With .ListBox2
            DoEvents
            .Top = 115
            .Width = 100
            .Height = 150
            .Left = 120
            .Font.Size = 10
            .TabStop = False
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With .ListBox3
            .Top = 115: .Width = 100: .Height = 150
            .Left = 230
            .Font.Size = 10
            .TabStop = False
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With .ListBox4
            .Top = 115: .Width = 100: .Height = 150
            .Left = 340
            .Font.Size = 10
            .TabStop = False
            .SpecialEffect = fmSpecialEffectEtched
        End With
        With .ListBox5
            .Top = 115: .Width = 100: .Height = 150
            .Left = 450
            .Font.Size = 10
            .TabStop = False
            .SpecialEffect = fmSpecialEffectEtched
        End With

        ' Buttons
        With .CommandButton1
            .Top = 280: .Width = 40: .Height = 20
            .Font.Size = 8: .Font.Bold = True
            .Left = 10
            .Caption = "Go to:"
            .Accelerator = "G"
        End With
        With .Label8
            .Top = 283: .Width = 120: .Height = 20
            .Font.Size = 10: .Font.Underline = True
            .ForeColor = RGB(22, 0, 245)
            .Left = 55
            .Caption = ActiveSheet.Name & "!" & Selection.Address
        End With
        With .CommandButton2
            .Top = 280: .Width = 100: .Height = 20
            .Font.Size = 8: .Font.Bold = True
            .Left = 230
            .Caption = "Previous Precedents"
            .Accelerator = "P"
        End With
        With .CommandButton3
            .Top = 280: .Width = 100: .Height = 20
            .Font.Size = 8: .Font.Bold = True
            .Left = 340
            .Caption = "Next Precedents"
            .Accelerator = "N"
        End With
        With .CommandButton4
            .Top = 280: .Width = 100: .Height = 20
            .Font.Size = 8: .Font.Bold = True
            .Left = 450
            .Caption = "Close Tracer"
            .Accelerator = "C"
        End With

        Call Update_Listbox(.ListBox1, Split(Precedents_Csv(Selection), ","))

    End With

End Sub

Private Sub Update_Listbox(list_box As Object, list_array As Variant)
    Dim i As Integer
    With list_box
        .Clear
        For i = 0 To UBound(list_array)
            .AddItem list_array(i)
        Next i
    End With
End Sub

Private Sub Update_Formulabox(address_argument As String)

    On Error GoTo ErrorExit
    Dim r As Range
    Dim target_range As Range
    Dim formula_box As Object

    Set target_range = Address_To_Range(address_argument)
    Set formula_box = UFM_TRACE.TextBox2
        formula_box.Value = ""

    If target_range.Count >= 2 Then
        For Each r In target_range
            formula_box.Value = formula_box.Value & "," & r.Address
        Next r
        formula_box.Value = Mid(formula_box, 2)
    ElseIf target_range.HasFormula = True Then
        formula_box.Value = target_range.Formula
    Else
        formula_box.Value = target_range.Value
    End If

ErrorExit:
End Sub

Private Sub Change_Listbox(list_box As Object)

    On Error GoTo ErrorExit
    Dim selected_address As String

    With list_box
        selected_address = .List(.ListIndex)
    End With

    Flex_Select selected_address

ErrorExit:
End Sub