「参照先のトレースの一覧表示」に機能追加・不具合改修を行った

先日このようなアドオンを開発してみた。

www.excellovers.com

実戦投入して何点かいじりたい箇所を発見したので、さっそく手を付けてみた。

改修箇所

• 機能追加
  • 検索起点セルの追加
  • 参照元検索の追加
  • トレース先選択の追加
• 不具合改修
  • 保護されたシートでエラーになる
  • 結合されたセルでの挙動

ユーザーフォームの改修

上記の機能追加のために何点かパーツを追加している。

完成品動作

• 検索起点セルの追加

以前のバージョンでは参照先一覧からセルを飛び回っていると元のセルがどこかわからなくなっていた。
そこで元々の検索対象セルを表示して参照先と同じように対象セルにジャンプできるようにした。

• 参照元検索

参照元検索なんて使ったことないと思ったけど、参照元の場合は数式を見て追い掛けていたことに気づいたので機能を追加。
参照元の場合、対象となるセルが多くなりすぎる危険性があるので直接参照のみとした。

• トレース先選択の追加

トレース先に対して何かしら一括で処理をしたくなる時があるので、対象セルの選択機能を追加。
アクティブシートのセルのみを対象としている。

• 保護されたシートでエラーになる

当アドオンの機能は「参照先のトレース」で表示される矢印機能を利用している。
しかしこの機能はシートが保護されていると利用することが出来ない。

このようにグレーアウトする。
この状態ではVBAでも矢印が保持している参照先情報を取得することが出来ないためエラーになってしまっていた。

これを回避する処理を追加した。

• 結合されたセルでの挙動

当アドオンでは元々複数セルを選択していると利用できないようにしていた。
しかし結合セルの場合１つの結合セルだけ選択していても複数セルを選択していると判断されてアドオンが起動できなくなっていた。

これを回避する処理を追加した。

コード

今回の機能追加についてはコメントを記載している。

Option Explicit

Private Sub CheckBox1_Change()
     '参照元検索は検索先が増えすぎるので直接参照のみに制限
     If Me.CheckBox1.Value Then
          Me.CheckBox2.Value = False
          Me.CheckBox2.Enabled = False
     ElseIf Me.CheckBox1.Value = False Then
          Me.CheckBox2.Enabled = True
     End If
End Sub
'-----------------------------------------------------------------
Private Sub CheckBox2_Change()
     '参照元検索は検索先が増えすぎるので直接参照のみに制限
     If Me.CheckBox2.Value Then
          Me.CheckBox1.Value = False
          Me.CheckBox1.Enabled = False
     ElseIf Me.CheckBox2.Value = False Then
          Me.CheckBox1.Enabled = True
     End If
End Sub
'-----------------------------------------------------------------
Private Sub CommandButton1_Click()
     Me.ListBox1.Clear
     Me.TextBox1.Value = ""
     Dim DependentsRng As Range
     If DependentsRng Is Nothing Then Set DependentsRng = Selection
     
     '対象セル範囲が結合セルを含まないもしくは結合セル・非結合セルが混在する場合
     If (Not DependentsRng.MergeCells Or IsNull(DependentsRng.MergeCells)) _
          And DependentsRng.Count >= 2 Then MsgBox "セルは１つだけ選択可", vbInformation + vbOKOnly, "複数セル選択不可": Exit Sub
     Me.TextBox1.Value = Selection.Parent.Name & "," & Selection.Address
Application.ScreenUpdating = False
     DependentsSearch Selection, Me.CheckBox1.Value, Me.CheckBox2.Value
     
     Dim myWS As Worksheet
     For Each myWS In Worksheets
          If myWS.ProtectContents = False Then myWS.ClearArrows
     Next
Application.ScreenUpdating = True
     If Me.ListBox1.ListCount = 0 Then MsgBox "参照" & IIf(Me.CheckBox2.Value, "元", "先") & "は見つかりません", vbInformation + vbOKOnly, "検索結果"
End Sub
'-----------------------------------------------------------------
'*******************************************************************************
'処理内容 : 参照先・参照元のセルアドレスをListboxの記載する
'引数　　 :DependentsRng：参照先・参照元を検索する対象となるセル
'            :notDirectSearch：検索対象を直接参照先のみとするか参照先の参照先まで全て検索するか。Trueで全て検索
'            :PrecendentsSearch：検索対象を参照先とするか参照元とするか。Trueで参照元を検索
'*******************************************************************************
Private Sub DependentsSearch(DependentsRng As Range, Optional notDirectSearch As Boolean = False, Optional PrecendentsSearch As Boolean = False)
     Dim i As Long: i = 1
     Dim n As Long: n = 1
     Dim myRng As Range
     
On Error Resume Next
     'シートが保護されていると参照先・参照元のトレース機能が使用できないため処理を行わない
     Do Until DependentsRng.Parent.ProtectContents
          '表示する矢印の向きを設定
          If PrecendentsSearch Then
               DependentsRng.ShowPrecedents
          Else
               DependentsRng.ShowDependents
          End If
          Do
               Set myRng = DependentsRng.NavigateArrow(TowardPrecedent:=PrecendentsSearch, 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, PrecendentsSearch
               n = n + 1
               Set myRng = Nothing
          Loop Until False
          i = i + 1
          n = 1
     Loop
breaklabel:
On Error GoTo 0
End Sub
'-----------------------------------------------------------------
Private Sub CommandButton2_Click()
     Unload Me
End Sub
'-----------------------------------------------------------------
'抽出した参照先・参照元のセルを選択状態にする
'アクティブシートのセルのみ選択する
Private Sub CommandButton3_Click()
     If Me.ListBox1.ListCount > 0 Then
          Dim myWS As Worksheet: Set myWS = ActiveSheet
          Dim i As Long
          Dim myList As Variant
          Dim myRng As Range
          
          For i = 0 To Me.ListBox1.ListCount - 1
               myList = Split(Me.ListBox1.List(i), ",")
               If myWS.Name = myList(0) Then
                    If myRng Is Nothing Then
                         Set myRng = Range(myList(1))
                    Else
                         Set myRng = Union(myRng, Range(myList(1)))
                    End If
               End If
          Next
          myRng.Select
     End If
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
'-----------------------------------------------------------------
Private Sub ListBox2_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
'-----------------------------------------------------------------
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim Adr As String
    Dim myWS As Worksheet
    Dim myList As Variant
    
    myList = Split(Me.TextBox1.Value, ",")
    Set myWS = Worksheets(myList(0))
    Adr = myList(1)

    myWS.Activate
    Range(Adr).Activate
End Sub

まとめ

毎度思うが実際に使ってみることで、自分が必要なものがやっとこさ見えてくる。
最初から計画すべきなのだろうが、なかなか自分には難しい。