トップ　>　汎用コード　>　数式の参照先・参照元セルアドレス一覧を作成する

'-----------------------------------------------------------------------------------
' 【実行マクロ】選択セル範囲の数式参照先・参照元セルアドレス一覧を作成するマクロ
'-----------------------------------------------------------------------------------
'［作成日］2024.01.27　［更新日］2024.01.28
' https://excel.syogyoumujou.com/vba/get_reference.html
'-----------------------------------------------------------------------------------
Sub createReferenceListOfSelectedCells()

    '------------------------------------
    ' 定数
    '------------------------------------
    Const MAX_CELLS_COUNT As Long = 1000          ' 調査可能とする最大セル数
    Const REFERENCE_OR_SOURCES As Boolean = False ' 数式の参照先をトレース：False
                                                  ' 数式の参照元をトレース：True
    '------------------------------------
    ' セル選択確認
    '------------------------------------
    If TypeName(Application.Selection) <> "Range" Then
        ' セルを選択していなければ終了
        MsgBox "セル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If

    '------------------------------------
    ' 調査対象セル個数確認
    '------------------------------------
    Dim rngTarget As Range
    Set rngTarget = Application.Selection
    If MAX_CELLS_COUNT < rngTarget.Cells.CountLarge Then
        ' 調査可能最大セル数を超えたセル範囲を選択してる場合は終了
        MsgBox "選択しているセルの個数が多すぎます" & vbLf & _
               "調査可能最大セル数：" & MAX_CELLS_COUNT, _
               vbExclamation, "終了します"
        Exit Sub
    End If

    '------------------------------------
    ' 参照をトレースし参照リストを記録
    '------------------------------------
    Dim rng     As Range
    Dim varList As Variant
    Dim dic     As Object
    Set dic = CreateObject("Scripting.Dictionary") ' 参照リスト記録用連想配列生成
    
    For Each rng In rngTarget
        '-----------------------------------------------------
        ' getReferenceCellAddressInArray1d
        '-----------------------------------------------------
        ' 引数１：調査対象の単一セル
        ' 引数２：参照先トレースか参照元トレースかの設定
        ' 戻り値：トレース対象のセルアドレスを格納した1次元配列
        ' 　　　　トレース対象がない場合は Empty
        ' 　　　　エラーの場合は -1
        '-----------------------------------------------------
        varList = getReferenceCellAddressInArray1d(rng, REFERENCE_OR_SOURCES)
        If IsArray(varList) Then
            ' セルアドレスをキーとして連想配列に参照の配列を追加
            dic.Add rng.Address(False, False), varList
        End If
    Next
    
    If dic.Count = 0 Then
        ' 参照がなければ終了
        If REFERENCE_OR_SOURCES Then
            MsgBox "選択セル範囲に参照元となっているセルはありません", vbInformation
        Else
            MsgBox "選択セル範囲を参照しているセルはありません", vbInformation
        End If
        Exit Sub
    End If

    '------------------------------------
    ' 新規ブックに一覧を出力
    '------------------------------------
    Application.ScreenUpdating = False
    With Workbooks.Add.Worksheets(1)
        ' 見出し設定
        .Range("A1:B1").Value = Array("ブック名", rngTarget.Worksheet.Parent.Name)
        .Range("A2:B2").Value = Array("シート名", rngTarget.Worksheet.Name)
        .Range("A3:B3").Value = Array("選択セル範囲", rngTarget.Address(False, False))
        .Range("A4").Value = IIf(REFERENCE_OR_SOURCES, "参照元", "参照先") & "のトレース"
        .Range("A5:B5").Value = Array("対象セル", "参照セルアドレス")
        With .Range("A1:A3," & .Rows(5).Address).Interior
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.799981688894314
        End With
        
        ' 一覧出力
        Dim lngRow          As Long
        Dim lngColumnsCount As Long
        Dim varKey          As Variant
        lngRow = 6
        lngColumnsCount = .Columns.Count
        For Each varKey In dic
            varList = dic(varKey)
            .Cells(lngRow, "A").Value = varKey
            If UBound(varList) + 1 < lngColumnsCount Then
                .Cells(lngRow, "B").Resize(1, UBound(varList) + 1).Value = varList
            Else
                .Cells(lngRow, "B").Value = "トレース対象が多すぎるため表示できません"
            End If
            lngRow = lngRow + 1
        Next
        .UsedRange.Columns.AutoFit
    End With
    Application.ScreenUpdating = True

    MsgBox "一覧を作成しました", vbInformation
    
End Sub

'-----------------------------------------------------------------------------------
' 参照セルアドレスを1次元配列で取得するプロシージャ
'-----------------------------------------------------------------------------------
'［引数］
'   rngTarget          ：調査対象セルを指定（単一セル）
'   ReferencesOrSources：参照先のトレースか参照元のトレースかの設定
'                        参照先のトレース：False（既定）
'                        参照元のトレース：True
'［戻り値］
'   トレース対象あり：トレース対象のセルアドレスを格納した1次元配列
'   トレース対象なし：Empty
'   エラー　　　　　：-1　（調査対象セルが単一でない）
'［作成日］2023.11.15　［更新日］2024.01.27
' https://excel.syogyoumujou.com/vba/get_reference.html
'［参考サイト］
' https://www.excellovers.com/entry/dependent01
'-----------------------------------------------------------------------------------
Function getReferenceCellAddressInArray1d(ByRef rngTarget As Range, _
                       Optional ByVal ReferencesOrSources As Boolean = False) As Variant
                                          
    If 1 < rngTarget.CountLarge Then
        ' 調査対象セルが複数の場合は戻り値を「-1」にしプロシージャを終了
        getReferenceCellAddressInArray1d = -1
        Exit Function
    End If
                               
    ' 変数
    Dim lngListCount        As Long    ' 配列数カウント用
    Dim lngArrowNumber      As Long    ' トレース矢印番号設定用
    Dim lngLinkNumber       As Long    ' 参照番号設定用
    Dim rng                 As Range   ' 参照セル設定用
    Dim strRngAddress       As String  ' 参照セルアドレス
    Dim varReferenceList()  As Variant ' 参照アドレス格納配列
    Dim strTargetAddress    As String  ' 対象セルアドレス格納
    Dim strCreateAddress(5) As String  ' セルアドレス作成用配列

    ' セルアドレス作成用の配列に既定値を設定
    strCreateAddress(0) = "["
    strCreateAddress(2) = "]"
    strCreateAddress(4) = "!"

    ' 調査セルの所属ブック名・シート名・セルアドレスを結合して変数に格納
    strCreateAddress(1) = rngTarget.Worksheet.Parent.Name           ' ブック名
    strCreateAddress(3) = rngTarget.Worksheet.Name                  ' シート名
    strCreateAddress(5) = rngTarget.MergeArea.Address(False, False) ' セルアドレス
    strTargetAddress = Join$(strCreateAddress, vbNullString)        ' 配列結合

    Application.ScreenUpdating = False
    rngTarget.Worksheet.ClearArrows
    If ReferencesOrSources Then
        ' 参照元のトレース
        rngTarget.ShowPrecedents
    Else
        ' 参照先のトレース
        rngTarget.ShowDependents
    End If
On Error Resume Next
START:
    lngArrowNumber = lngArrowNumber + 1
    lngLinkNumber = 1
    Do
        Set rng = Nothing
        Set rng = rngTarget.NavigateArrow(ReferencesOrSources, lngArrowNumber, lngLinkNumber)
        
        ' トレース対象のセルがNothingの場合はループ開始に戻る
        ' 調査セルにトレース対象が1つでもあるとループを経て最終的にNothingとなる
        ' （ただし結合セルに所属のセルは、最終的に結合セルが返る）
        If rng Is Nothing Then GoTo START
        
        ' トレース対象セルの所属ブック名・シート名・セルアドレスを結合して変数に格納
        strCreateAddress(1) = rng.Worksheet.Parent.Name
        strCreateAddress(3) = rng.Worksheet.Name
        strCreateAddress(5) = rng.Address(False, False)
        strRngAddress = Join$(strCreateAddress, vbNullString)
                
        ' 調査セルにトレース対象が1つもない場合は抜ける
        ' トレース対象が1つもない場合、 調査セルとトレース対象セルのアドレスが同じになる
        If strTargetAddress = strRngAddress Then GoTo FINALLY
        
        ' アドレス格納用配列拡張
        ReDim Preserve varReferenceList(lngListCount)
        varReferenceList(lngListCount) = strRngAddress
        lngListCount = lngListCount + 1
        lngLinkNumber = lngLinkNumber + 1
    Loop
FINALLY:
On Error GoTo 0
    rngTarget.Worksheet.ClearArrows
    Application.ScreenUpdating = True
    If lngListCount = 0 Then Exit Function
    getReferenceCellAddressInArray1d = varReferenceList
End Function