Compare commits
No commits in common. "c0d4d3ac84f421591063d6cea92b2ba23be99bbb" and "aafd771ea4cd472352dc84c034fc4605ca6e9ab1" have entirely different histories.
c0d4d3ac84
...
aafd771ea4
@ -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
|
|
||||||
135
JSON.bas
135
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
|
|
||||||
|
|
||||||
@ -15,7 +15,6 @@ Attribute VB_PredeclaredId = True
|
|||||||
Attribute VB_Exposed = False
|
Attribute VB_Exposed = False
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Public proceed As Boolean
|
Public proceed As Boolean
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user