LoginSignup
2
4

More than 5 years have passed since last update.

@XHacks

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

Posted at

トレース機能の貧弱さ

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

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
2
4
1

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
4