Option Explicit
Sub RedefineRange()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose: Remove all existing range names in the workbook, then
' recreate them from a list
'
' Assumption: The user has previously extracted a list of all range
' names using Insert | Name | Paste | Paste List in cell A1
' of a blank sheet, then modified, added or deleted names
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim nm As Name ' each name in workbook
Dim rng As Range ' list of range names to recreate
On Error Goto ErrHandler
If Range("A1").Formula = "" Then
MsgBox "No range names detected", vbInformation, "No Data"
Else
' user to confirm before proceeding
If vbYes = MsgBox("This will remove all existing range names and " & vbCrLf & _
"only recreate the names listed here." & vbCrLf & vbCrLf & _
"Do you want to continue?", _
vbYesNo + vbQuestion + vbDefaultButton2, _
"Redefine Range Names") Then
' remove all existing range names
For Each nm In ActiveWorkbook.Names
Application.StatusBar = "Removing range name " & nm.Name
nm.Delete
Next nm
Application.DisplayAlerts = False
For Each rng In Range(Range("A1"), Range("A1").End(xlDown))
Application.StatusBar = "Adding range " & rng.Formula
ActiveWorkbook.Names.Add rng.Formula, rng.Offset(0, 1).Formula, True
Next rng
Range("A1").Select
Selection.ListNames
End If
End If
ExitHere:
Application.StatusBar = False
Application.DisplayAlerts = True
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Resume ExitHere
End Sub
|