ListNamedRanges

' ListNamedRanges
' -----------------
' Macro Name: ListNamedRanges
' Description: ブック内の名前定義（Named Ranges）をすべて一覧表示する
' Parameters: なし
' Returns: なし
' Usage: 実行すると名前定義の一覧がアクティブシートに出力される
' -----------------

Sub ListNamedRanges()
    Dim wb As Workbook
    Dim nm As Name
    Dim ws As Worksheet
    Dim outputRow As Long
    Dim lastRow As Long

    On Error GoTo ErrorHandler

    Set wb = ActiveWorkbook

    If wb.Names.Count = 0 Then
        MsgBox "名前定義は存在しません。", vbInformation
        Exit Sub
    End If

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    If lastRow < 1 Then lastRow = 1

    outputRow = lastRow + 2

    ws.Cells(outputRow, 1).Value = "名前定義一覧"
    ws.Cells(outputRow, 1).Font.Bold = True
    ws.Cells(outputRow, 1).Font.Size = 14
    outputRow = outputRow + 1

    ws.Cells(outputRow, 1).Value = "名前"
    ws.Cells(outputRow, 2).Value = "参照範囲"
    ws.Cells(outputRow, 3).Value = "スコープ"
    ws.Cells(outputRow, 1).Font.Bold = True
    ws.Cells(outputRow, 2).Font.Bold = True
    ws.Cells(outputRow, 3).Font.Bold = True
    ws.Range(ws.Cells(outputRow, 1), ws.Cells(outputRow, 3)).Interior.Color = RGB(200, 200, 200)
    outputRow = outputRow + 1

    For Each nm In wb.Names
        ws.Cells(outputRow, 1).Value = nm.Name
        ws.Cells(outputRow, 2).Value = nm.RefersTo
        If nm.WorkbookParameter Then
            ws.Cells(outputRow, 3).Value = "ブック"
        Else
            ws.Cells(outputRow, 3).Value = "シート"
        End If
        outputRow = outputRow + 1
    Next nm

    ws.Columns("A:C").AutoFit
    MsgBox "名前定義を " & wb.Names.Count & " 件出力しました。", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
End Sub