List Named Ranges in Active Sheet

List Named Ranges of the Active Sheet

Sub ListActiveSheetNamedRanges()
    
    ' Define constants.
    Const PROC_NAME As String = "ListActiveSheetNamedRanges"
    Const REMOVE_SHEET_NAME_FROM_RANGE_NAME As Boolean = False ' worksheet scope
    
    ' Validate the (active) sheet.
    If ActiveSheet Is Nothing Then
        MsgBox "There is no active sheet (""Nothing"")!", _
            vbExclamation, PROC_NAME
        Exit Sub
    End If
    If Not TypeOf ActiveSheet Is Worksheet Then
        MsgBox "The sheet """ & ActiveSheet.Name & """ is no worksheet!", _
            vbExclamation, PROC_NAME
        Exit Sub
    End If
    
    ' Reference (active) sheet, its workbook, and retrieve the sheet's name.
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim wb As Workbook: Set wb = ws.Parent
    Dim SheetName As String: SheetName = ws.Name
    
    ' Declare additional variables.
    Dim nm As Name, rg As Range
    Dim RangeName As String, ResultString As String
    Dim WasFirstFound As Boolean
    
    ' Loop through the names of the workbook and apply the required logic.
    For Each nm In wb.Names
        Set rg = Nothing ' reset (dereference) on each iteration
        On Error Resume Next ' prevent error when no range
            Set rg = nm.RefersToRange
        On Error GoTo 0
        If Not rg Is Nothing Then ' the name refers to a range
            If rg.Worksheet.Name = SheetName Then ' the range is on the sheet
                ' Write top result rows (only once).
                If Not WasFirstFound Then
                    ResultString = "Named Ranges in Sheet """ & SheetName _
                        & """:" & vbLf
                    WasFirstFound = True ' never reset
                End If
                ' Retrieve the name's name.
                RangeName = nm.Name
                ' Optionally, remove the sheet name from the range name.
                If REMOVE_SHEET_NAME_FROM_RANGE_NAME Then
                    If TypeOf nm.Parent Is Worksheet Then ' is worksheet scope
                        RangeName = Right(RangeName, _
                            Len(RangeName) - InStrRev(RangeName, "!")) ' remove
                    'Else ' is of workbook scope
                    End If
                'Else ' keep sheet name in range name
                End If
                ' Append current named range data to the result string.
                ResultString = ResultString & vbLf _
                    & RangeName & " (""" & nm.RefersTo & """)"
            'Else ' the range is on another sheet
            End If
        'Else ' the name doesn't refer to a range
        End If
    Next nm
    
    ' Display the resulting list in a message box.
    If WasFirstFound Then
        'Debug.Print ResultString
        MsgBox ResultString, vbInformation, PROC_NAME
    Else
        MsgBox "No named ranges found in sheet """ & ws.Name _
            & """ of workbook """ & wb.Name & """!", _
            vbExclamation, PROC_NAME
    End If
    
End Sub