Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　参照先セル一覧表を作成する
'
'  Copyright(C) 2000 Sunago
'
Option Explicit

Sub Macro1()
Dim objTarget As Worksheet  ' 処理対象シート
Dim objResult As Worksheet  ' 結果記入シート
Dim rngAreas As Range       ' 数式セルの範囲
Dim rngCell As Range        ' 処理対象セル
Dim myPrecedent As Range    ' 参照元セル
    
    '対象シートを設定する
    Set objTarget = Worksheets("Sheet1")
    '出力シートを設定する
    On Error Resume Next
    Set objResult = Sheets(objTarget.Name & "_Precedents")
    On Error GoTo 0
    If objResult Is Nothing Then
        Set objResult = Worksheets.Add(after:=objTarget)
        objResult.Name = objTarget.Name & "_Precedents"
      Else
        objResult.Cells.Clear
    End If
    '数式が含まれるセルを選択し、処理する。
    For Each rngAreas In _
            objTarget.Range("A1").SpecialCells(xlCellTypeFormulas, 23).Areas
        For Each rngCell In rngAreas
            '参照元セルとなっているか、Precedentsプロパティを
            '使って判断する
            On Error Resume Next
            Set myPrecedent = rngCell.Precedents
            On Error GoTo 0
            If Not myPrecedent Is Nothing Then
                If myPrecedent.Parent.Name = objTarget.Name Then
                '参照先が自シートの場合
                    objResult.Range(rngCell.Address) = myPrecedent.Address(False, False)
                Else
                'それ以外の場合
                    objResult.Range(rngCell.Address) = myPrecedent.Parent.Name & "!" & myPrecedent.Address(False, False)
                End If
            End If
            Set myPrecedent = Nothing
        Next
    Next
    Set objResult = Nothing
    Set objTarget = Nothing
End Sub