CODEWITHSUNDEEP
excelvba
Qqqqq
Qqqqq

Reputation: 175

VBA to delete unused named ranges in Excel

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

Upvotes: 2

Views: 4983

Answers (2)

FAB
FAB

Reputation: 2569

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

Upvotes: 3

Slai
Slai

Reputation: 22866

Another alternative could be to check if the name range has any dependents :

Function HasDependents(r As Range)
    r.ShowDependents
    HasDependents = r.Address(, , , 1) <> r.NavigateArrow(0, 1).Address(, , , 1)
    r.ShowDependents 1
End Function

Sample use :

For Each xName In xWB.Names
    If Not HasDependents(xName.RefersToRange) Then xName.Delete
Next

Technically, this does not check if the name is used, but only if the range the name refers to is used (assuming all names refer to range). To go through the dependents and check if their formulas contain the name, this sample can be modified : https://excelhelphq.com/how-to-find-all-dependent-cells-outside-of-worksheet-and-workbook-in-excel-vba/

Upvotes: 1

Related Questions