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

数式の参照先・参照元セルアドレス一覧を作成する2024.01.27 更新:2024.01.28

選択しているセル範囲の各セルを調査し、数式の参照先や参照元になっている場合、参照セルアドレスの一覧を新規ブックに作成するマクロです。

※このコードでは一般的な数式の参照先や参照元を対象としています。
 INDIRECT関数による文字列をセルの参照とするようなケースには対応していませんのでご留意ください。

■参考動画
選択セル範囲で数式の参照先となっているセルの参照一覧を作成する ※動画内の個人名や点数はダミーデータです



セル範囲を選択し、マクロ「createReferenceListOfSelectedCells」を実行すると一覧が作成されます。

このマクロは、若干時間を要するため、1回のマクロ実行で調査するセル数を制限しています。
初期値で1000としていますが、変更する場合はコードの次の定数の数値を変更してください。
Const MAX_CELLS_COUNT As Long = 1000

また調査セルにおいて、参照先をトレースするか、参照元をトレースするかは、コードの次の定数の値を変更してください。
Const REFERENCE_OR_SOURCES As Boolean = False
False は参照先をトレースし True は参照元をトレースします。

このマクロは次のサイト様を参考にしています。
「参照先のトレース」が不満で、選択したセルを参照しているセルを一覧で表示できるようにした


【お薦め】マクロ・プロシージャを管理する無料のツール!
 Excelマクロ管理ツール

サンプルコード2024.01.27 更新:2024.01.28

コードの貼り付け場所   VBAコードをカラーで印刷・Web掲載するためのツールはこちら

'-----------------------------------------------------------------------------------
' 【実行マクロ】選択セル範囲の数式参照先・参照元セルアドレス一覧を作成するマクロ
'-----------------------------------------------------------------------------------
'[作成日]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:調査対象の単一セル
        ' 引数2:参照先トレースか参照元トレースかの設定
        ' 戻り値:トレース対象のセルアドレスを格納した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("対象セル", "参照セルアドレス")
        .Range("A1:A3," & .Rows(5).Address).Interior.Color = RGB(217, 225, 242)
        
        ' 一覧出力
        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

ページトップへ戻る

Excel 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.