Add CleanDefinedNames macro to strip junk defined names

Whitelist-keep deletion of legacy/corrupt workbook defined names (Bloomberg/SAP/Lotus debris); keeps real names + Excel tables. Error-handles corrupt =#NAME? entries.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>

CleanDefinedNames.bas

@@ -0,0 +1,96 @@
+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, "_xlnm.", vbTextCompare) > 0 Then
+            ' Built-in print areas / titles - leave alone
+            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
+
+    report = "Done." & vbCrLf & _
+             "Deleted: " & deleted & vbCrLf & _
+             "Kept (whitelist): " & kept & vbCrLf & _
+             "Skipped (_xlnm built-ins): " & skipped & vbCrLf & _
+             "Failed (corrupt - need XML fix): " & failed & vbCrLf & _
+             "Remaining names: " & ThisWorkbook.Names.Count
+    If failed > 0 Then report = report & vbCrLf & vbCrLf & _
+             "First few that failed:" & vbCrLf & failedList
+    MsgBox report, vbInformation, "CleanDefinedNames"
+End Sub

JSON.bas

@@ -0,0 +1,135 @@
+Attribute VB_Name = "JSON"
+Option Explicit
+
+'====== Public API ======'
+' UDF: returns JSON as string (may be large for a cell)
+Public Function RangeToJSON(tbl As Range, Optional TreatEmptyAsNull As Boolean = True) As String
+    On Error GoTo Fail
+    RangeToJSON = BuildJSON(tbl, TreatEmptyAsNull)
+    Exit Function
+Fail:
+    RangeToJSON = "[]"
+End Function
+
+' Macro: saves the selected range to a JSON file
+Public Sub ExportRangeToJSON()
+    Dim rng As Range, js As String, f As Variant, ff As Integer
+    If TypeName(Selection) <> "Range" Then
+        MsgBox "Please select a rectangular range first.", vbExclamation
+        Exit Sub
+    End If
+    Set rng = Selection
+    js = BuildJSON(rng, True)
+    f = Application.GetSaveAsFilename(InitialFileName:="data.json", FileFilter:="JSON Files (*.json), *.json")
+    If f = False Then Exit Sub
+    ff = FreeFile
+    Open CStr(f) For Output As #ff
+    Print #ff, js
+    Close #ff
+    MsgBox "Saved JSON to: " & f, vbInformation
+End Sub
+
+'====== Core ======'
+Private Function BuildJSON(tbl As Range, TreatEmptyAsNull As Boolean) As String
+    Dim arr As Variant, r As Long, c As Long
+    Dim rCount As Long, cCount As Long
+    Dim headers() As String
+    Dim rows() As String
+    Dim pairs() As String
+    Dim rowJSON As String
+
+    If tbl Is Nothing Then BuildJSON = "[]": Exit Function
+    If tbl.rows.Count < 2 Or tbl.Columns.Count < 1 Then BuildJSON = "[]": Exit Function
+
+    arr = tbl.Value ' 1-based 2D variant array
+    rCount = UBound(arr, 1)
+    cCount = UBound(arr, 2)
+
+    ' Guard: header-only range
+    If rCount < 2 Then BuildJSON = "[]": Exit Function
+
+    ' Build headers (escape blanks to col1/col2/...)
+    ReDim headers(1 To cCount)
+    For c = 1 To cCount
+        headers(c) = JsonEscape(CStr(arr(1, c)))
+        If Len(headers(c)) = 0 Then headers(c) = "col" & CStr(c)
+    Next c
+
+    ' Build each row object: {"h1":val1,"h2":val2,...}
+    ReDim rows(1 To rCount - 1)
+    For r = 2 To rCount
+        ReDim pairs(1 To cCount)
+        For c = 1 To cCount
+            pairs(c) = """" & headers(c) & """:" & CellToJSON(arr(r, c), TreatEmptyAsNull)
+        Next c
+        rowJSON = "{" & Join(pairs, ",") & "}"
+        rows(r - 1) = rowJSON
+    Next r
+
+    ' Final JSON array
+    BuildJSON = "[" & Join(rows, ",") & "]"
+End Function
+
+
+'====== Helpers ======'
+Private Function CellToJSON(v As Variant, TreatEmptyAsNull As Boolean) As String
+    On Error GoTo Fallback
+    ' Errors ? null
+    If IsError(v) Then CellToJSON = "null": Exit Function
+    ' Empty/blank
+    If (VarType(v) = vbEmpty) Or (VarType(v) = vbNull) Or (CStr(v) = "") Then
+        If TreatEmptyAsNull Then
+            CellToJSON = "null"
+        Else
+            CellToJSON = """" & """"
+        End If
+        Exit Function
+    End If
+    ' Boolean
+    If VarType(v) = vbBoolean Then
+        CellToJSON = IIf(CBool(v), "true", "false")
+        Exit Function
+    End If
+    ' Date
+    If IsDate(v) Then
+        CellToJSON = """" & Format$(CDate(v), "yyyy-mm-dd\THH:nn:ss") & """"
+        Exit Function
+    End If
+    ' Numeric (locale-safe with dot)
+    If IsNumeric(v) Then
+        Dim s As String
+        s = CStr(CDbl(v))
+        s = Replace(s, Application.DecimalSeparator, ".")
+        CellToJSON = s
+        Exit Function
+    End If
+    ' String
+    CellToJSON = """" & JsonEscape(CStr(v)) & """"
+    Exit Function
+Fallback:
+    CellToJSON = "null"
+End Function
+
+Private Function JsonEscape(s As String) As String
+    ' Minimal, safe escaping for JSON
+    Dim t As String
+    t = Replace(s, "\", "\\")
+    t = Replace(t, """", "\""")
+    t = Replace(t, vbCrLf, "\n")
+    t = Replace(t, vbCr, "\n")
+    t = Replace(t, vbLf, "\n")
+    ' Control chars 0–31 ? strip (simple approach)
+    Dim i As Long, ch As String, code As Integer, out As String
+    out = ""
+    For i = 1 To Len(t)
+        ch = Mid$(t, i, 1)
+        code = AscW(ch)
+        If code < 32 Then
+            ' skip control chars (or map to \u00XX if desired)
+        Else
+            out = out & ch
+        End If
+    Next i
+    JsonEscape = out
+End Function
+

login.frm

@@ -15,6 +15,7 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+
 Public proceed As Boolean