如何获取所有Excel命名范围的列表

我的一些Excel文件有许多Excel命名范围。如何在一个地方轻松列出它们？信息应该包括诸如姓名、地址、包含信息的表格等内容

打开Excel文件时，可以转到功能区的“公式”区域，并在“定义的名称”选项卡中选择“在公式中使用”。最底部是“粘贴名称”选项。但它只提供一个没有标题的名称和值列表。另外，如果您尝试按地址对它们进行排序，则会得到B1、B10、B11、B2、B20、B21、B3等

我在OzGrid.com和MrExcel.com上找到了VBA代码的示例，但没有一个完全符合我的要求

下面的答案是一些VBA代码，它将创建一个工作表，其中包含工作表名称、范围名称、绝对和相对地址、列和行以及原始行的列，以便您在排序后始终可以返回原始列表。它还包括用于筛选的计数小计公式

---

请注意，将跳过包含多个单元格的任何命名区域（例如过滤器）。

将以下代码粘贴到模块中并运行它

Option Explicit

' Assumes a sheet with the CodeName RangeNames.

Private Const m_CountCol As String = "A"
Private Const m_FormulaCol As String = "B"

Private Const m_SheetCol As String = "A"
Private Const m_NameCol As String = "B"
Private Const m_AbsoluteAddressCol As String = "C"
Private Const m_RelativeAddressCol As String = "D"
Private Const m_ColumnCol As String = "E"
Private Const m_RowCol As String = "F"
Private Const m_ValueCol As String = "G"
' Allows for sorting and still always being able to get back to the original order.
Private Const m_OrigRowCol As String = "H"
Private Const m_IndexCol As String = "I"

Private Sub LoadNamedRanges()
Dim lRow As Long, lEndCol As Long, lCounter As Long, lSkipped As Long, lIndex As Long, lRangeNameRow As Long
Dim sRefersTo As String, sSheet As String, sAbsoluteAddress As String, sRelativeAddress As String, sColumn As String, sMessage As String
Dim vColumns As Variant
Dim oName As Name

    ' Alternatively use the following instead.
    ' With ThisWorkbook.Sheets("Your Sheet Name")

    ' This assumes a sheet with the CodeName RangeNames
    With RangeNames
        .Cells.EntireColumn.Clear
        .Cells.EntireColumn.ClearComments
        .Cells.EntireColumn.ClearFormats
        
        ' Delete any skinny rows from prior runs.
        Call .Rows("1:1000").Delete(shift:=xlUp)
        
        lRow = 1
        .Cells(lRow, m_NameCol).Value = "Name"
        .Cells(lRow, m_SheetCol).Value = "Sheet"
        .Cells(lRow, m_AbsoluteAddressCol).Value = "Absolute Addr"
        .Cells(lRow, m_RelativeAddressCol).Value = "Relative Addr"
        .Cells(lRow, m_ColumnCol).Value = "Col"
        .Cells(lRow, m_RowCol).Value = "Row"
        .Cells(lRow, m_ValueCol).Value = "Value"
        .Cells(lRow, m_OrigRowCol).Value = "OrigRow"
        ''.Cells(lRow, m_IndexCol).Value = "Index"
        
        For Each oName In Names
            ' Skip named ranges in our Named Range sheet.
            If InStr(1, oName.Name, .Name, vbTextCompare) > 0 Then
                lSkipped = lSkipped + 1
            ' Skip named ranges that contain more than one cell (e.g. Print ranges).
            ElseIf InStr(oName.RefersTo, ":") > 0 Then
                lSkipped = lSkipped + 1
            Else
                lRow = lRow + 1
                lCounter = lCounter + 1
                sRefersTo = Replace$(Replace$(oName.RefersTo, "=", vbNullString), "'", vbNullString)
                sSheet = Left$(sRefersTo, InStr(sRefersTo, "!") - 1)
                sAbsoluteAddress = Mid$(sRefersTo, InStr(sRefersTo, "!") + 1, 1000)
                sRelativeAddress = Replace$(Mid$(sRefersTo, InStr(sRefersTo, "!") + 1, 1000), "$", vbNullString, 1, 1)
                sColumn = Left$(sRelativeAddress, InStr(sRelativeAddress, "$") - 1)
                lRangeNameRow = CLng(Mid$(sRelativeAddress, InStr(sRelativeAddress, "$") + 1, 1000))
                sRelativeAddress = Replace$(sRelativeAddress, "$", vbNullString)
                .Cells(lRow, m_NameCol).Value = oName.Name
                .Cells(lRow, m_SheetCol).Value = sSheet
                .Cells(lRow, m_AbsoluteAddressCol).Value = sAbsoluteAddress
                .Cells(lRow, m_RelativeAddressCol).Value = sRelativeAddress
                .Cells(lRow, m_ColumnCol).Value = sColumn
                .Cells(lRow, m_RowCol).Value = lRangeNameRow
                .Cells(lRow, m_ValueCol).Value = "'" & oName.Value
                .Cells(lRow, m_OrigRowCol).Value = lCounter
                ''.Cells(lRow, m_IndexCol).Value = oName.Index
                
                Call LoadColumnsArray(vColumns, sColumn)
            End If
        Next
        
        lEndCol = .Cells(1, Application.Columns.Count).End(xlToLeft).Column
        .Range(.Cells(1, "A"), .Cells(lRow, lEndCol)).AutoFilter
        .Cells.EntireColumn.AutoFit
        
        ' Add a Subtotal formula for filtered counts.
        ' It will include the header column plus one additional blank row.
        lRow = lRow + 1
        .Rows(lRow).RowHeight = 3
        sAbsoluteAddress = "$B$1:$B$" & lRow
        lRow = lRow + 1
        .Cells(lRow, m_CountCol) = "Count"
        .Cells(lRow, m_CountCol).HorizontalAlignment = xlRight
        .Cells(lRow, m_FormulaCol).Formula = "=SubTotal(103, " & sAbsoluteAddress & ") - 1"
        .Cells(lRow, m_FormulaCol).HorizontalAlignment = xlLeft
        .Cells(lRow, m_FormulaCol).NumberFormat = "###,###,##0"
        
        ' Insert blank row at top and copy SubTotal formula cell.
        lRow = lRow + 1
        Call .Rows(1).Insert(shift:=xlDown)
        .Cells(1, m_CountCol) = "Count"
        .Cells(1, m_CountCol).HorizontalAlignment = xlRight
        .Cells(1, m_FormulaCol).Formula = "=" & m_FormulaCol & lRow
        .Cells(1, m_FormulaCol).HorizontalAlignment = xlLeft
        .Cells(1, m_FormulaCol).NumberFormat = "###,###,##0"
                
        .Activate
        .Cells(3, "A").Select
    End With
    
    With ActiveWindow
        .FreezePanes = False
        .FreezePanes = True
    End With
    
    sMessage = GetMessage(lCounter, lSkipped, vColumns)
    
    Call MsgBox(sMessage, vbInformation, "Info")
    Set oName = Nothing
End Sub

Private Sub LoadColumnsArray(vColumns As Variant, sColumn As String)
Dim lIndex As Long
Dim bMatched As Boolean
    If IsEmpty(vColumns) Then
        ReDim vColumns(1, 0)
        vColumns(0, 0) = sColumn
        vColumns(1, 0) = 0
    Else
        For lIndex = LBound(vColumns, 2) To UBound(vColumns, 2)
            If vColumns(0, lIndex) = sColumn Then
                bMatched = True
                Exit For
            End If
        Next
        If Not bMatched Then
            ReDim Preserve vColumns(1, UBound(vColumns, 2) + 1)
            vColumns(0, UBound(vColumns, 2)) = sColumn
            vColumns(1, UBound(vColumns, 2)) = 0
        End If
    End If
    vColumns(1, lIndex) = vColumns(1, lIndex) + 1
End Sub

Private Function GetMessage(lCounter As Long, lSkipped As Long, vColumns As Variant) As String
Dim lIndex As Long
Dim sMessage As String
    sMessage = "Processed " & lCounter & " named range(s)," & vbNewLine & _
                "Skipped " & lSkipped & " named range(s), " & vbNewLine
                
    For lIndex = LBound(vColumns, 2) To UBound(vColumns, 2)
        sMessage = sMessage & "Col: " & vColumns(0, lIndex) & " " & vColumns(1, lIndex) & ", " & vbNewLine
        ''Debug.Print vColumns(0, lIndex), vColumns(1, lIndex)
    Next
    
    sMessage = Trim$(sMessage)
    sMessage = Trim$(Left$(sMessage, Len(sMessage) - Len(vbNewLine)))
    sMessage = Left$(sMessage, Len(sMessage) - 1) & "."
    
    GetMessage = sMessage
End Function