I have several workbooks that contain 3,500+ named ranges, most of which are not used. To clean up the mess, I would like to run a macro that deletes any unused names.
The following macro seems to work, but it takes about half an hour to run. I actually turned on the status bar so I could be sure it was still progressing.
I would like to get advice on how to accomplish this task more efficiently.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
xFound = xFound + xWS.UsedRange.Find(What:=xName.Name, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).count
If xFound > 0 Then Exit For 'Name was found. Stop looking.
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
As commented above, please give this a try.
Is putting all the formulas in arrays rather than named ranges.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Dim arrData As Variant 'an array to hold all formulas
Dim R As Long, C As Long 'rows/columns
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.Count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
arrData = xWS.UsedRange.Formula
For R = LBound(arrData) To UBound(arrData)
For C = LBound(arrData, 2) To UBound(arrData, 2)
If InStr(1, arrData(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could replace that loop with the below, should hold all data (... well, hopefully). If all the usedranges load successfully, then it should be a breeze to loop through everything.
Dim Z As Long
Dim arrWholeData() As Variant: ReDim arrWholeData(xWB.Worksheets.Count)
For Z = 1 To xWB.Worksheets.Count
arrWholeData(Z) = xWB.Worksheets(Z).UsedRange.Formula
Next Z
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Z = 1 To xWB.Worksheets.Count
For R = LBound(arrWholeData(Z)) To UBound(arrWholeData(Z))
For C = LBound(arrWholeData(Z), 2) To UBound(arrWholeData(Z), 2)
If InStr(1, arrWholeData(Z)(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
If xFound > 0 Then Exit For
Next Z
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
EDIT: added an alternative.
EDIT: FINAL COMPLETE CODE:
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim startTime As Single, endTime As Single
startTime = Timer
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xNameCount As Long: xNameCount = xWB.Names.count
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeleted As Long 'Count of deleted named ranges
Dim xArrWholeData() As Variant: ReDim xArrWholeData(xWB.Worksheets.count)
Dim xRow As Long 'Row number
Dim xCol As Long 'Column number
Dim xName As Name 'Used for looping through names
Dim xWSNum As Long 'Used for looping through worksheets
Dim xNName As String 'Name of current named range in the loop - used for comparing
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For xWSNum = 1 To xWB.Worksheets.count
xArrWholeData(xWSNum) = xWB.Worksheets(xWSNum).UsedRange.Formula
Next xWSNum
For Each xName In xWB.Names
xNName = xName.Name
xCount = xCount + 1
If xCount Mod 50 = 0 Then
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
End If
If xNName Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
For xWSNum = 1 To xWB.Worksheets.count
If xWB.Worksheets(xWSNum).Name Like "Workbook Properties" Then 'Skip the Workbook Properties worksheet
Else
For xRow = LBound(xArrWholeData(xWSNum)) To UBound(xArrWholeData(xWSNum))
For xCol = LBound(xArrWholeData(xWSNum), 2) To UBound(xArrWholeData(xWSNum), 2)
If InStr(1, xArrWholeData(xWSNum)(xRow, xCol), xNName) > 0 Then
xFound = 1 'Name was found
GoTo NextName 'Stop looking for this name and go to the next name
End If
Next xCol
Next xRow
End If
Next xWSNum
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xDeleted = xDeleted + 1
xName.Delete
End If
End If
NextName:
Next xName
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
If xDeleted = 0 Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeleted & " names were deleted:", , "Unused named ranges were deleted" 'Removed & vbCr & xMsg before the first comma
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub