Delete Name Ranges by Scope VBA

[Admin]

Hi All,


Here is a workaround which allows you to delete the name ranges from a workbook where both the scope exists of same name


Option Explicit
Public Enum NameScope
xlWorkbook = 0
xlWorksheet = 1
End Enum
Sub DeleteNamedRanges(ByRef Wbk As Workbook, ScopeLevel As NameScope)

'// Developed by : Krishnakumar @ ExcelFox.com

Dim lngLoop As Long
Dim lngIndex As Long
Dim strName As String
Dim wksTemp As Worksheet
Dim lngSU As Long
Dim lngCalc As Long
Dim lngEE As Long
Dim lngDA As Long


With Application
lngSU = .ScreenUpdating
lngCalc = .Calculation
lngDA = .DisplayAlerts
lngEE = .EnableEvents
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
End With

Set wksTemp = Wbk.Worksheets.Add

With Wbk
For lngLoop = .Names.Count To 1 Step -1
If ScopeLevel = xlWorksheet Then
If TypeOf .Names(lngLoop).Parent Is Worksheet Then
strName = Split(.Names(lngLoop).Name, "!")(1)
If GLOBALLYEXISTS(Wbk, strName) Then
.Names(lngLoop).Delete
End If
End If
ElseIf ScopeLevel = xlWorkbook Then
If TypeOf .Names(lngLoop).Parent Is Workbook Then
strName = "!" & .Names(lngLoop).Name
If LOCALLYEXISTS(Wbk, strName) Then
.Names(lngLoop).Delete
End If
End If
End If
Next
End With

wksTemp.Delete

With Application
.ScreenUpdating = lngSU
.Calculation = lngCalc
.DisplayAlerts = lngDA
.EnableEvents = lngEE
End With

End Sub
Private Function GLOBALLYEXISTS(ByRef Wbk As Workbook, ByVal NameName As String) As Boolean

Dim lngLoop As Long
Dim lngSU As Long

With Application
lngSU = .ScreenUpdating
.ScreenUpdating = False
End With

With Wbk
For lngLoop = .Names.Count To 1 Step -1
If .Names(lngLoop).Name = NameName Then
If TypeOf .Names(lngLoop).Parent Is Workbook Then
GLOBALLYEXISTS = True
GoTo Xit
End If
End If
Next
End With
Xit:
Application.ScreenUpdating = lngSU

End Function
Private Function LOCALLYEXISTS(ByRef Wbk As Workbook, ByVal NameName As String) As Boolean

Dim lngLoop As Long
Dim lngSU As Long

With Application
lngSU = .ScreenUpdating
.ScreenUpdating = False
End With

With Wbk
For lngLoop = .Names.Count To 1 Step -1
If .Names(lngLoop).Name Like "*" & NameName Then
If TypeOf .Names(lngLoop).Parent Is Worksheet Then
LOCALLYEXISTS = True
GoTo Xit
End If
End If
Next
End With
Xit:
Application.ScreenUpdating = lngSU

End Function

and call the procedure as


Sub kTest()

'Delete Local Names where both the scope exists (Local and Global)
DeleteNamedRanges ThisWorkbook, xlWorksheet

'Delete Global Names where both the scope exists (Local and Global)
'DeleteNamedRanges ThisWorkbook, xlWorkbook

End Sub