VBA/CleanDefinedNames.bas

Attribute VB_Name = "CleanDefinedNames"
Option Explicit

' ============================================================
'  CleanDefinedNames  -  removes legacy/junk defined names
'  Keeps a whitelist of real names; skips _xlnm built-ins.
'  Excel Tables are not in the Names collection, so they are
'  never touched. RUN ON A COPY FIRST.
' ============================================================
Sub CleanDefinedNames()
    Dim nm As Name
    Dim keep As Object
    Dim deleted As Long, kept As Long, skipped As Long, failed As Long
    Dim report As String, failedList As String, nmName As String
    Dim i As Long

    Set keep = CreateObject("Scripting.Dictionary")
    keep.CompareMode = vbTextCompare      ' case-insensitive

    ' ---- defined names to KEEP (point to Cover cells) ----
    keep.Add "Report_Date", 1
    keep.Add "Value_Base", 1
    keep.Add "FSPR_Date", 1

    ' ---- Excel Tables: not in Names collection, listed for safety ----
    keep.Add "Addbacks.key", 1
    keep.Add "Company.Codes", 1
    keep.Add "DC.Code", 1
    keep.Add "Dept", 1
    keep.Add "Entity", 1
    keep.Add "Forecasting.Periods", 1
    keep.Add "Levels", 1
    keep.Add "Months", 1
    keep.Add "Period", 1
    keep.Add "Period_end", 1
    keep.Add "Plant.Codes", 1
    keep.Add "SalesData", 1
    keep.Add "Segm", 1
    keep.Add "Statement", 1
    keep.Add "TB", 1
    keep.Add "TB.EBITDA2", 1
    keep.Add "Table4", 1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Iterate backwards (deleting while looping)
    For i = ThisWorkbook.Names.Count To 1 Step -1
        Set nm = ThisWorkbook.Names(i)

        ' Reading .Name can itself raise on corrupt entries
        nmName = vbNullString
        On Error Resume Next
        nmName = nm.Name
        On Error GoTo 0

        If Len(nmName) > 0 And keep.Exists(nmName) Then
            kept = kept + 1
        ElseIf InStr(1, nmName, "_xl", vbTextCompare) = 1 Then
            ' Excel-reserved system names - leave alone:
            '   _xlnm. = built-in print areas/titles
            '   _xlfn. = future-function markers (XLOOKUP, SWITCH, SUMIFS, ...)
            '   _xlcn. = data-model / linked-table connection names
            ' Deleting these breaks formulas / the data model.
            skipped = skipped + 1
        Else
            ' Corrupt names (=#NAME?, illegal chars) make Excel re-validate
            ' and throw 1004 on .Delete. Swallow, try a fallback, and keep going.
            On Error Resume Next
            Err.Clear
            nm.Delete
            If Err.Number <> 0 Then
                Err.Clear
                nm.Visible = True       ' un-hide, sometimes lets it delete
                nm.Delete
            End If
            If Err.Number <> 0 Then
                failed = failed + 1
                If Len(failedList) < 1500 Then _
                    failedList = failedList & nmName & vbCrLf
            Else
                deleted = deleted + 1
            End If
            On Error GoTo 0
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    ' --- collect surviving names (name <TAB> refers-to) for the clipboard ---
    Dim survivors As String, nn As Name, rt As String
    survivors = "Name" & vbTab & "RefersTo" & vbCrLf
    For Each nn In ThisWorkbook.Names
        rt = ""
        On Error Resume Next
        rt = nn.RefersTo
        On Error GoTo 0
        survivors = survivors & nn.Name & vbTab & rt & vbCrLf
    Next nn
    Dim copied As Boolean
    copied = PutOnClipboard(survivors)

    report = "Done." & vbCrLf & _
             "Deleted: " & deleted & vbCrLf & _
             "Kept (whitelist): " & kept & vbCrLf & _
             "Skipped (_xl* system names): " & skipped & vbCrLf & _
             "Failed: " & failed & vbCrLf & _
             "Remaining names: " & ThisWorkbook.Names.Count
    If failed > 0 Then report = report & vbCrLf & vbCrLf & _
             "First few that failed:" & vbCrLf & failedList
    report = report & vbCrLf & vbCrLf & _
             IIf(copied, "Remaining names copied to clipboard (paste anywhere).", _
                         "(Could not access clipboard - see Immediate window.)")
    If Not copied Then Debug.Print survivors
    MsgBox report, vbInformation, "CleanDefinedNames"
End Sub

' Put text on the Windows clipboard without a library reference,
' via the MSForms.DataObject class GUID. Returns True on success.
Private Function PutOnClipboard(ByVal s As String) As Boolean
    On Error GoTo fail
    Dim dobj As Object
    Set dobj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    dobj.SetText s
    dobj.PutInClipboard
    PutOnClipboard = True
    Exit Function
fail:
    PutOnClipboard = False
End Function