CleanDefinedNames.bas

@@ -1,96 +0,0 @@
-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

@@ -1,135 +0,0 @@
-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,7 +15,6 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
-
 Public proceed As Boolean