Posted at

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

More than 1 year has passed since last update.


トレース機能の貧弱さ


  • 参照先の確認は、「参照先のトレース」または「参照先へジャンプ」で行える

  • 一方、他シートを参照していると挙動が怪しいなど、不便な点が多い

  • また、参照先の参照先を見たりしていると、もとのセルに戻れなくなる


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