Also try this:
Option Explicit
Option Compare Text
Public Sub ListAllNamesInWorkbook()
On Error GoTo ErrorHandler:
Const strcWsName As String = "Range Names"
Dim lngCnt As Long: lngCnt = 2
Dim nm As Excel.Name
Dim wb As Excel.Workbook: Set wb = ActiveWorkbook
Dim ws As Excel.Worksheet
Dim lngXlCalc As Excel.XlCalculation
'Speed things up
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
lngXlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
'Validate workbook
If wb Is Nothing Then
Err.Raise Number:=vbObjectError + 3321
End If
'Add worksheet
If wb.Names.Count > 0 Then
Set ws = wb.Worksheets.Add(After:=wb.Worksheets
(wb.Worksheets.Count))
Else
MsgBox "No range names are defined in the active workbook.", _
vbInformation + vbOKOnly, "Nothing found"
GoTo ExitProc:
End If
'Header
ws.Name = strcWsName
With ws.Range("A1")
.Value = "Name:"
.Offset(, 1).Value = "Local?"
.Offset(, 2).Value = "Referes to:"
.Offset(, 3).Value = "Hidden?"
.Offset(, 4).Value = "Value:"
.Offset(, 5).Value = ""
End With
'Loop names
For Each nm In wb.Names
With ws
'Parse local names
If InStr(1, nm.Name, "!") > 0 Then
.Cells(lngCnt, 1).Value = Right(nm.Name, Len(nm.Name)
- InStr(1, nm.Name, "!"))
.Cells(lngCnt, 2).Value = "Yes"
Else
.Cells(lngCnt, 1).Value = nm.Name
.Cells(lngCnt, 2).Value = "No"
End If
.Cells(lngCnt, 3).Value = "'" & nm.RefersTo
.Cells(lngCnt, 4).Value = IIf(nm.Visible, "No", "Yes")
'Check for multiple areas in formula
If InStr(1, nm.Value, _
Application.International(xlListSeparator)) = 0 _
And InStr(1, nm.Value, ":") = 0 Then
.Cells(lngCnt, 5).Value = nm.Value
End If
End With
lngCnt = lngCnt + 1
Next nm
'Format output
With ws
.Rows(1).Font.Bold = True
Union(.Columns(2), .Columns(4)).HorizontalAlignment = xlCenter
.Columns.EntireColumn.AutoFit
End With
ExitProc:
On Error Resume Next
'Reset
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = lngXlCalc
Set nm = Nothing
Set wb = Nothing
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Select Case Err.Number
Case vbObjectError + 3321
MsgBox "Unable to list range names." & vbCr & "No workbook is
" _
& "currently active.", vbInformation + vbOKOnly, "Problem"
Case 1004
MsgBox "Unable to list range names." & vbCr & "A worksheet
with the " _
& "name """ & strcWsName & """ already exists." & vbCr _
& "Please rename or delete this worksheet.", _
vbInformation + vbOKOnly, "Problem"
Case Else
MsgBox "An unhandled error occured." & vbCr & "Number: " &
Err.Number _
& vbCr & "Description: " & vbCr & Err.Description, _
vbCritical + vbOKOnly, "Unhandeled error"
End Select
ws.Delete
Resume ExitProc:
End Sub
best regards
Peder Schmedling
