参照シート解析マクロ

Excelのシート内で別シートを参照しているものがあれば、その一覧を作成するマクロです。

```
Option Explicit

Sub シート参照分析()
    Dim filePath As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim refSheet As Worksheet
    Dim resultSheet As Worksheet
    Dim mainSheet As Worksheet
    Dim currentRow As Long
    Dim formulaStr As String
    Dim refSheets As Collection
    Dim sheetName As Variant
    Dim searchRange As Range
    Dim foundCell As Range
    
    ' メインシートからファイルパスを取得
    Set mainSheet = ThisWorkbook.Worksheets("メイン")
    filePath = mainSheet.Range("C2").Value
    
    ' ファイルが指定されていない場合は終了
    If filePath = "" Then
        MsgBox "ファイルパスが指定されていません。", vbExclamation
        Exit Sub
    End If
    
    ' Excelファイルを開く
    On Error Resume Next
    Set wb = Workbooks.Open(filePath)
    If Err.Number <> 0 Then
        MsgBox "ファイルを開けませんでした。パスを確認してください。", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 「解析結果」シートを作成（存在する場合は削除）
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("解析結果").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    ' メインシートの直後に解析結果シートを追加
    Set resultSheet = ThisWorkbook.Worksheets.Add(After:=mainSheet)
    resultSheet.Name = "解析結果"
    
    ' 結果シートのヘッダー作成
    resultSheet.Cells(1, 1).Value = "ワークブック名"
    resultSheet.Cells(1, 2).Value = "シート名"
    resultSheet.Cells(1, 3).Value = "参照シート"
    
    ' 結果シートの行カウンタ
    currentRow = 2
    
    ' 全シートをループ
    For Each ws In wb.Worksheets
        ' ステータスバーにシート名を表示
        Application.StatusBar = "現在のシート: " & ws.Name
        
        ' 参照シートのコレクションを初期化
        Set refSheets = New Collection
        
        ' 検索範囲を設定
        Set searchRange = ws.Range("A1:ZZ5000")
        
        ' 「!」を含むセルを検索
        Set foundCell = searchRange.Find(What:="!", LookIn:=xlFormulas, LookAt:=xlPart)
        
        ' 検索結果がある場合
        If Not foundCell Is Nothing Then
            Dim firstAddress As String
            firstAddress = foundCell.Address
            
            Do
                ' ステータスバーにセルアドレスを表示
                Application.StatusBar = "現在のシート: " & ws.Name & " - セル: " & foundCell.Address
                
                ' セルの数式を取得
                formulaStr = foundCell.Formula
                
                ' シート参照を抽出
                Call 参照シート抽出(formulaStr, wb, refSheets)
                
                ' 次のセルを検索
                Set foundCell = searchRange.FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
        End If
        
        ' 参照シートがある場合、結果シートに出力
        If refSheets.Count > 0 Then
            For Each sheetName In refSheets
                ' 文字列として書き込み、先頭に'を追加して数式として解釈されないようにする
                resultSheet.Cells(currentRow, 1).Value = "'" & wb.Name
                resultSheet.Cells(currentRow, 2).Value = "'" & ws.Name
                resultSheet.Cells(currentRow, 3).Value = "'" & sheetName
                currentRow = currentRow + 1
            Next sheetName
        End If
    Next ws
    
    ' 結果シートの列幅を自動調整
    resultSheet.Columns.AutoFit
    
    ' 開いたワークブックを閉じる
    wb.Close SaveChanges:=False
    
    ' ステータスバーをクリア
    Application.StatusBar = False
    
    MsgBox "シート参照分析が完了しました。", vbInformation
End Sub

Private Function シート名クリーニング(元のシート名 As String) As String
    Dim 分割文字列() As String
    Dim 分割用シート名 As String

    分割用シート名 = 元のシート名
    分割用シート名 = Replace(分割用シート名, "(", ",")
    分割用シート名 = Replace(分割用シート名, "=", ",")
    分割用シート名 = Replace(分割用シート名, "-", ",")
    分割用シート名 = Replace(分割用シート名, "+", ",")
    分割用シート名 = Replace(分割用シート名, "*", ",")
    分割用シート名 = Replace(分割用シート名, "/", ",")
    
    ' 分割文字で分割
    分割文字列 = Split(分割用シート名, ",")
    
    ' 最後の要素を返す（空白を削除）
    If UBound(分割文字列) >= 0 Then
        シート名クリーニング = Trim(分割文字列(UBound(分割文字列)))
    Else
        ' 分割文字がない場合はそのまま返す
        シート名クリーニング = 元のシート名
    End If
End Function

Private Sub 参照シート抽出(formulaStr As String, wb As Workbook, refSheets As Collection)
    Dim sheetNames() As String
    Dim i As Long
    Dim uniqueSheetName As Variant
    
    ' シート参照を抽出する拡張正規表現パターン
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    ' 以下のパターンに対応：
    ' 1. 'シート名'!
    ' 2. シート名!
    ' 3. [ワークブック名]シート名!
    regEx.Pattern = "(?:(?:\[([^\]]+)\])?'?([^'!]+)'?!)(?=[A-Z0-9])"
    
    Dim matches As Object
    Set matches = regEx.Execute(formulaStr)
    
    ' 一意の参照シート名をコレクションに追加
    For i = 0 To matches.Count - 1
        Dim workbookName As String
        Dim sheetName As String
        Dim cleanedSheetName As String
        
        ' ワークブック名が指定されている場合
        If matches(i).SubMatches(0) <> "" Then
            workbookName = matches(i).SubMatches(0)
            sheetName = matches(i).SubMatches(1) & " [" & workbookName & "]"
        Else
            ' ワークブック名が指定されていない場合（同一ワークブック内参照）
            sheetName = matches(i).SubMatches(1)
        End If
        
        ' シート名をクリーニング
        cleanedSheetName = シート名クリーニング(sheetName)
        
        ' 同じシート名が既に存在しない場合のみ追加
        Dim exists As Boolean
        exists = False
        For Each uniqueSheetName In refSheets
            If uniqueSheetName = cleanedSheetName Then
                exists = True
                Exit For
            End If
        Next uniqueSheetName
        
        If Not exists Then
            ' クリーニングされたシート名でコレクションに追加
            refSheets.Add cleanedSheetName
        End If
    Next i
End Sub
```