「参照先のトレース」が不満で、選択したセルを参照しているセルを一覧で表示できるようにした

「参照先のトレース」という機能をご存知だろうか？

この機能を使用するとこのように選択したセルを参照しているセルがどこにあるか、矢印で可視化してくれる便利な機能である。
が、一つ好きじゃない点がある。

この部分である。
「参照先のトレース」はアクティブシート以外から参照されている場合、点線矢印で表示される。
この点線矢印をダブルクリックすると、ジャンプ機能が開いてアクティブシート以外の参照先が表示される。

しかしこの機能が使いにくい。
使い方の順番は下記の通り。

1. 点線矢印をダブルクリック
2. 開いたジャンプ機能で参照先を選択
3. 参照先を確認
4. 1に戻る

一々細い矢印をダブルクリックしないといけないのめんどい。
何番目まで見たかわからなくてイライラする。

そうだそんな時は自作だ！

完成品動作

完成形の動作は以下のようになっている。

一度検索すれば、結果が常に表示されているため、一々細い矢印をクリックしたりせずに済むようになっている。

コード

Private Sub CommandButton1_Click()
     Me.ListBox1.Clear
     Dim DependentsRng As Range
     If DependentsRng Is Nothing Then Set DependentsRng = Selection
     If DependentsRng.Count >= 2 Then MsgBox "セルは１つだけ選択可", vbInformation + vbOKOnly, "複数セル選択不可": Exit Sub
Application.ScreenUpdating = False
     DependentsSearch Selection, Me.CheckBox1.Value
     
     Dim myWS As Worksheet
     For Each myWS In Worksheets
          myWS.ClearArrows
     Next
Application.ScreenUpdating = True
     If Me.ListBox1.ListCount = 0 Then MsgBox "参照先は存在しません", vbInformation + vbOKOnly, "検索結果"
End Sub
'--------------------------------------------------------
Private Sub DependentsSearch(DependentsRng As Range, Optional notDirectSearch As Boolean = False)
     Dim i As Long: i = 1
     Dim n As Long: n = 1
     Dim myRng As Range
On Error Resume Next
     Do
          DependentsRng.ShowDependents
          Do
               Set myRng = DependentsRng.NavigateArrow(TowardPrecedent:=False, arrownumber:=i, linknumber:=n)
               'ループ脱出条件---------------------------------
               '参照先１つでもある場合最終的にはエラーが発生してmyRngがNothingになる
               '参照先が１つもない場合NavigateArrowの引数に何を指定してもDependentsRngが返ってくる
               If myRng Is Nothing Then Exit Do
               If DependentsRng.Parent.Name & ":" & DependentsRng.Address = myRng.Parent.Name & ":" & myRng.Address Then GoTo breaklabel
               '------------------------------------------------
               Me.ListBox1.AddItem myRng.Parent.Name & "," & myRng.Address
               If notDirectSearch Then DependentsSearch myRng, notDirectSearch
               n = n + 1
               Set myRng = Nothing
          Loop Until False
          i = i + 1
          n = 1
     Loop Until False
breaklabel:
On Error GoTo 0
End Sub
'--------------------------------------------------------
Private Sub CommandButton2_Click()
     Unload Me
End Sub
'--------------------------------------------------------
Private Sub ListBox1_Click()
'リストボックスに表示された検索結果をクリックすると、検索結果へ移動する
    Dim Adr As String
    Dim myWS As Worksheet
    Dim myList As Variant
    
    myList = Split(ListBox1.List(ListBox1.ListIndex), ",")
    Set myWS = Worksheets(myList(0))
    Adr = myList(1)

    myWS.Activate
    Range(Adr).Activate
End Sub

NavigateArrow

参照先のセルを取得するために NavigateArrow を使用している。

Range.NavigateArrow(owardPrecedent, ArrowNumber, LinkNumber) as Range

引数	内容
TowardPrecedent	参照の方向を指定。Trueで参照元。Falseで参照先
ArrowNumber	対象となるトレース矢印を指定
LinkNumber	トレース矢印が外部参照を表すとき、この引数でどの外部参照を対象とするかを指定

NavigateArrowは参照先・参照元のRangeオブジェクトを返す。
返ってくるRangeオブジェクトは複数の参照先・参照元があれば複数のRangeオブジェクトになる。

ループ脱出条件

コード内のコメントにも記載しているが、２重ループの脱出条件を２つ用意している。

If myRng Is Nothing Then Exit Do

１つ目は１つでも参照先があるArrowNumber(第2引数)の場合の対応。
１つでも参照先があるArrowNumberの場合NavigateArrowの第３引数に参照先が存在しない(２以上の)数値を指定するとエラーになる。
ここで１つ目のループを抜けて、処理を次のArrowNumberに移行させる。

If DependentsRng.Parent.Name & ":" & DependentsRng.Address = myRng.Parent.Name & ":" & myRng.Address

2つ目は１つも参照先がないArrowNumber(第2引数)の場合の対応。
参照先が１つもないArrowNumberの場合、第3引数が32,767以下の自然数であればエラーにならず、現在選択中のRangeオブジェクトを返す。

そこで現在選択中のRangeオブジェクトとNavigateArrowの返り値のRangeオブジェクトを比較して同じならば、現在選択中のセルには参照先が存在しないということで、次の矢印への移動ではなく２重ループを一気に抜けて次のセルに処理を移動している。

まとめ

実は処理の中で参照先の矢印を表示している。
この矢印を表示しないと正しく参照先を取得できないため仕方ないのだが、なんとなく不細工な手順だなぁと思っている。

この点を含めて改良案があれば改良していきたいと思う。