Excel内相関関係解析マクロ

Excelだファイルの各シートで別シートを参照している場合、その参照関係を一覧化するマクロです。

Sub AnalyzeSheetReferences()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim resultWs As Worksheet
    Dim filePath As String
    Dim targetWb As Workbook
    Dim sheetNames As Collection
    Dim i As Integer, j As Integer
    Dim currentSheet As Worksheet
    Dim searchSheet As Worksheet
    Dim cell As Range
    Dim searchString As String
    Dim resultRow As Integer
    Dim found As Boolean
    
    ' エラーハンドリング
    On Error GoTo ErrorHandler
    
    ' 現在のワークブックを取得
    Set wb = ThisWorkbook
    
    ' メインシートのC2セルからファイルパスを取得
    filePath = wb.Sheets("メイン").Range("C2").Value
    
    ' ファイルパスが空の場合はエラー
    If filePath = "" Then
        MsgBox "C2セルにファイルパスが入力されていません。"
        Exit Sub
    End If
    
    ' ファイルが存在するかチェック
    If Dir(filePath) = "" Then
        MsgBox "指定されたファイルが存在しません: " & filePath
        Exit Sub
    End If
    
    ' 対象のExcelファイルを開く
    Set targetWb = Workbooks.Open(filePath)
    
    ' 解析結果シートが既に存在する場合は削除
    For Each ws In wb.Worksheets
        If ws.Name = "解析結果" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next ws
    
    ' 解析結果シートを作成
    Set resultWs = wb.Worksheets.Add
    resultWs.Name = "解析結果"
    
    ' ヘッダーを設定
    resultWs.Range("A1").Value = "ワークブック名"
    resultWs.Range("B1").Value = "現在のシート名"
    resultWs.Range("C1").Value = "参照先シート名"
    
    ' 結果出力の開始行
    resultRow = 2
    
    ' 全シートのシート名リストを作成
    Set sheetNames = New Collection
    For Each ws In targetWb.Worksheets
        sheetNames.Add ws.Name
    Next ws
    
    ' 全シートをループ
    For Each currentSheet In targetWb.Worksheets
        ' シート名リストをループ
        For i = 1 To sheetNames.Count
            searchString = sheetNames(i) & "!"
            found = False
            
            ' 現在のシートで検索文字列を検索
            For Each cell In currentSheet.UsedRange
                If cell.HasFormula Then
                    ' 数式内で検索
                    If InStr(cell.Formula, searchString) > 0 Then
                        found = True
                        Exit For
                    End If
                ElseIf Not IsEmpty(cell.Value) Then
                    ' セル値内で検索
                    If InStr(CStr(cell.Value), searchString) > 0 Then
                        found = True
                        Exit For
                    End If
                End If
            Next cell
            
            ' ヒットした場合は結果を出力
            If found Then
                resultWs.Cells(resultRow, 1).Value = targetWb.Name
                resultWs.Cells(resultRow, 2).Value = currentSheet.Name
                resultWs.Cells(resultRow, 3).Value = sheetNames(i)
                resultRow = resultRow + 1
            End If
        Next i
    Next currentSheet
    
    ' 対象のExcelファイルを閉じる
    targetWb.Close SaveChanges:=False
    
    ' 結果シートを選択
    resultWs.Select
    
    ' 列幅を自動調整
    resultWs.Columns("A:C").AutoFit
    
    MsgBox "解析が完了しました。結果は「解析結果」シートに出力されました。"
    
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
    
    ' 開いたファイルがある場合は閉じる
    If Not targetWb Is Nothing Then
        targetWb.Close SaveChanges:=False
    End If
End Sub