refactor some logic

TheBigOne.cls

@@ -451,7 +451,7 @@ Sub SHTp_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, B
         Dim i As Integer
         i = 0
         For i = 0 To UBound(NumFields())
-            Call sh.Columns(NumFields(i) + 1).TextToColumns
+            Call sh.Columns(NumFields(i) + col).TextToColumns
         Next i
     End If
     
@@ -869,8 +869,8 @@ On Error GoTo err_active
 
 '---------------get first recordset that has >0 column count--------------------
 
-    If ADOo_rs(con_from).Fields.Count = 0 Then
-        Do Until ADOo_rs(con_from).Fields.Count <> 0
+    If ADOo_rs(con_from).fields.Count = 0 Then
+        Do Until ADOo_rs(con_from).fields.Count <> 0
             Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset()
             If ADOo_rs(con_from) Is Nothing Then Exit Do
         Loop
@@ -898,7 +898,7 @@ On Error GoTo err_active
 
 '-------------Make sure number of fields same in both record sets--------------------
 
-    If ADOo_rs(con_to).Fields.Count <> ADOo_rs(con_from).Fields.Count Then
+    If ADOo_rs(con_to).fields.Count <> ADOo_rs(con_from).fields.Count Then
         ADOo_errstring = "Field count in MoveRecords function not equal"
         ADOp_MoveRecords = False
         Exit Function
@@ -913,14 +913,14 @@ On Error GoTo err_active
     While ADOo_rs(con_from).EOF = False
         rc = rc + 1
         ADOo_rs(con_to).AddNew
-        For i = 0 To ADOo_rs(con_from).Fields.Count - 1
-            If IsNull(ADOo_rs(con_from).Fields(i)) Then
-                ADOo_rs(con_to).Fields(i) = ""
+        For i = 0 To ADOo_rs(con_from).fields.Count - 1
+            If IsNull(ADOo_rs(con_from).fields(i)) Then
+                ADOo_rs(con_to).fields(i) = ""
             Else
                 If trim Then
-                    ADOo_rs(con_to).Fields(i) = LTrim(RTrim(ADOo_rs(con_from).Fields(i)))
+                    ADOo_rs(con_to).fields(i) = LTrim(RTrim(ADOo_rs(con_from).fields(i)))
                 Else
-                    ADOo_rs(con_to).Fields(i) = ADOo_rs(con_from).Fields(i)
+                    ADOo_rs(con_to).fields(i) = ADOo_rs(con_from).fields(i)
                 End If
             End If
         Next i
@@ -951,7 +951,7 @@ err_inactive:
 
 err_active:
     If Err.Number <> 0 Then
-        ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con_from).Fields(i).Name & " record " & rc
+        ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con_from).fields(i).Name & " record " & rc
         ADOp_MoveRecords = False
         ADOo_con(con_to).RollbackTrans
         ADOo_rs(con_to).Close
@@ -1015,8 +1015,8 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
     'size table
     Dim table() As String
     
-    If ADOo_rs(con).Fields.Count = 0 Then
-        Do Until ADOo_rs(con).Fields.Count <> 0
+    If ADOo_rs(con).fields.Count = 0 Then
+        Do Until ADOo_rs(con).fields.Count <> 0
             Set ADOo_rs(con) = ADOo_rs(con).NextRecordset()
             If ADOo_rs(con) Is Nothing Then Exit Do
         Loop
@@ -1026,17 +1026,17 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
             ADOp_ExtractRecordsetS = table
             Exit Function
         Else
-            ReDim table(ADOo_rs(con).Fields.Count - 1, Size)
+            ReDim table(ADOo_rs(con).fields.Count - 1, Size)
         End If
     Else
-        ReDim table(ADOo_rs(con).Fields.Count - 1, Size)
+        ReDim table(ADOo_rs(con).fields.Count - 1, Size)
     End If
     
     'populate headers if requested
     If headers Then
         i = 0
         While i <= UBound(table, 1)
-            table(i, 0) = ADOo_rs(con).Fields(i).Name
+            table(i, 0) = ADOo_rs(con).fields(i).Name
             i = i + 1
         Wend
     End If
@@ -1052,14 +1052,14 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
     While ADOo_rs(con).EOF = False
         j = 0
         While j <= (UBound(table, 1))
-        If IsNull(ADOo_rs(con).Fields(j)) Then
+        If IsNull(ADOo_rs(con).fields(j)) Then
             table(j, i) = ""
         Else
             On Error Resume Next
             If trim Then
-                table(j, i) = LTrim(RTrim(ADOo_rs(con).Fields(j)))
+                table(j, i) = LTrim(RTrim(ADOo_rs(con).fields(j)))
             Else
-                table(j, i) = ADOo_rs(con).Fields(j)
+                table(j, i) = ADOo_rs(con).fields(j)
             End If
             If Err.Number <> 0 Then table(j, i) = "Error:" & Err.Number
             On Error GoTo err_active
@@ -1076,7 +1076,7 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
     
 err_active:
     If Err.Number <> 0 Then
-        ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con).Fields(j).Name & " record " & i
+        ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con).fields(j).Name & " record " & i
         ReDim table(0, 0)
         table(0, 0) = ADOo_errstring
         ADOp_ExtractRecordsetS = table
@@ -1733,62 +1733,82 @@ End Function
 
 
 Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolean
-    
+
     Dim i As Long
     Dim j As Long
-    Dim t() As String
     Dim wl As String
     Dim test_empty As String
     Dim tsf As New ADODB.Stream
-    
+    Dim field As String
+
     On Error GoTo errh
-    
-'    Dim f As New Scripting.FileSystemObject
-'    Dim ts As Scripting.TextStream
-'    Set ts = f.CreateTextFile(path, True, True)
-'    ts.Close
-    
-    
+
     tsf.Type = 2
-    'tsf.Charset = "utf-8"
     tsf.Charset = "Windows-1252"
     tsf.Open
-    
-    'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
-    
+
     i = 0
     While i <= UBound(recs, 2)
+        test_empty = ""
+        wl = ""
+        
         For j = 0 To UBound(recs, 1)
+            field = EscapeCSVField(recs(j, i))
             If j = 0 Then
-                test_empty = Replace(Replace(recs(j, i), ",", ""), """", "")
-                wl = Replace(Replace(recs(j, i), ",", ""), """", "")
+                wl = field
+                test_empty = trim(recs(j, i))
             Else
-                test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "")
-                wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "")
+                wl = wl & "," & field
+                test_empty = test_empty & trim(recs(j, i))
             End If
         Next j
+        
         If Len(test_empty) > 0 Then
             If i = 0 Then
-                Call tsf.WriteText(wl)
+                tsf.WriteText wl
             Else
-                wl = vbCrLf & wl
-                Call tsf.WriteText(wl)
+                tsf.WriteText vbCrLf & wl
             End If
         End If
+        
         i = i + 1
     Wend
-    Call tsf.SaveToFile(path, adSaveCreateOverWrite)
-    
+
+    tsf.SaveToFile path, adSaveCreateOverWrite
+
+    FILEp_CreateCSV = True
+    Exit Function
+
 errh:
-    If Err.Number = 0 Then
-        FILEp_CreateCSV = True
-    Else
-        MsgBox (Err.Description)
-        FILEp_CreateCSV = False
-    End If
+    MsgBox (Err.Description)
+    FILEp_CreateCSV = False
 
 End Function
 
+Private Function EscapeCSVField(ByVal s As Variant) As String
+    ' Make sure s is a string even if Null or Empty
+    If IsNull(s) Or IsEmpty(s) Then
+        s = ""
+    Else
+        s = CStr(s)
+    End If
+    
+    Dim needsQuotes As Boolean
+    needsQuotes = (InStr(1, s, ",") > 0) _
+                Or (InStr(1, s, """") > 0) _
+                Or (InStr(1, s, vbCr) > 0) _
+                Or (InStr(1, s, vbLf) > 0)
+    
+    If needsQuotes Then
+        s = Replace(s, """", """""")
+        EscapeCSVField = """" & s & """"
+    Else
+        EscapeCSVField = s
+    End If
+End Function
+
+
+
 Function FILEp_CreateTXT(ByRef path As String, ByRef recs() As String) As Boolean
     
     Dim i As Long
@@ -1877,63 +1897,101 @@ errh:
 End Function
 
 Function FILEp_GetCSV(filepath As String) As String()
-
     Dim fileNo As Integer
     Dim fileContent As String
     Dim fileLines() As String
     Dim dataArray() As String
-    Dim splitArray() As String
-    Dim rowCount As Long, colCount As Long
+    Dim parsed() As String
+    Dim rowCount As Long
     Dim i As Long, j As Long
-    Dim final() As String
-    
-    ' Get an available file number
+    Dim fields As Collection
+    Dim f As Variant
+
+    ' === Read entire file ===
     fileNo = FreeFile
-    
-    ' Open the file with the available file number
-    Open filepath For Input As fileNo
-    
-    ' Read the entire file content into a single string
-    fileContent = Input(LOF(fileNo), fileNo)
-    
-    ' Close the file
-    Close fileNo
-    
-    ' Split the file content into lines
-    fileLines = Split(fileContent, vbCrLf)
-    
-    ' Get the number of rows (lines)
+    Open filepath For Input As #fileNo
+    fileContent = Input(LOF(fileNo), #fileNo)
+    Close #fileNo
+
+    ' === Split into lines (support CRLF or LF only) ===
+    fileContent = Replace(fileContent, vbCrLf, vbLf)
+    fileContent = Replace(fileContent, vbCr, vbLf)
+    fileLines = Split(fileContent, vbLf)
+
     rowCount = UBound(fileLines) - LBound(fileLines)
-    
-    ' Check if there are any lines in the file
-    If rowCount > 0 Then
-        ' Split the first line into columns (using comma as a delimiter)
-        dataArray = Split(fileLines(0), ",")
-        
-        ' Get the number of columns
-        colCount = UBound(dataArray) - LBound(dataArray)
-        
-        ' Redimension the dataArray to the appropriate size
-        ReDim dataArray(0 To rowCount, 0 To colCount)
-        
-        ' Loop through the lines and columns to populate the dataArray
-        For i = 0 To rowCount
-            ' Split the current line into columns
-            splitArray = Split(fileLines(i), ",")
-            
-            ' Loop through the columns
-            For j = 0 To colCount
-                ' Assign the values to the dataArray
-                dataArray(i, j) = splitArray(j)
-            Next j
-        Next i
-        FILEp_GetCSV = dataArray
-    Else
-        MsgBox "The file is empty or not available."
+    If rowCount < 0 Then
+        MsgBox "File is empty."
+        Exit Function
     End If
-    
+
+    ' === First pass: count max columns ===
+    Dim maxCols As Long
+    maxCols = 0
+    For i = 0 To UBound(fileLines)
+        Set fields = ParseCSVLine(fileLines(i))
+        If fields.Count > maxCols Then maxCols = fields.Count
+    Next i
+
+    ' === Allocate array ===
+    ReDim dataArray(0 To UBound(fileLines), 0 To maxCols - 1)
+
+    ' === Second pass: fill array ===
+    For i = 0 To UBound(fileLines)
+        Set fields = ParseCSVLine(fileLines(i))
+        For j = 1 To fields.Count
+            dataArray(i, j - 1) = fields(j)
+        Next j
+    Next i
+
+    FILEp_GetCSV = dataArray
 End Function
 
+Private Function ParseCSVLine(ByVal line As String) As Collection
+    Dim fields As New Collection
+    Dim i As Long
+    Dim c As String
+    Dim token As String
+    Dim inQuotes As Boolean
+
+    i = 1
+    token = ""
+    inQuotes = False
+
+    Do While i <= Len(line)
+        c = Mid$(line, i, 1)
+
+        If inQuotes Then
+            If c = """" Then
+                If i < Len(line) And Mid$(line, i + 1, 1) = """" Then
+                    ' Escaped quote
+                    token = token & """"
+                    i = i + 1
+                Else
+                    inQuotes = False
+                End If
+            Else
+                token = token & c
+            End If
+        Else
+            If c = """" Then
+                inQuotes = True
+            ElseIf c = "," Then
+                fields.Add token
+                token = ""
+            Else
+                token = token & c
+            End If
+        End If
+
+        i = i + 1
+    Loop
+
+    fields.Add token
+    Set ParseCSVLine = fields
+End Function
+
+
+
 Public Function ADOp_Exec(ByRef con As Integer, ByVal sql As String, Optional ApproxSixe As Long, Optional InclHeaders As Boolean, Optional ByVal value As ADOinterface, Optional ConnectTo As String, Optional IntgrtdSec As Boolean, Optional UserName As String, Optional Password As String, Optional textconfigs As String) As Boolean
     
     On Error GoTo errflag
@@ -2304,7 +2362,7 @@ Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, Target As String, tri
 
 End Function
 
-Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
+Public Function json_from_table(ByRef tbl As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
 
 
     Dim ajson As String
@@ -2324,14 +2382,13 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
                 needs_braces = needs_braces + 1
                 If needs_comma Then json = json & ","
                 needs_comma = True
-                If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
+                If IsNumeric(tbl(r, c)) Then
                     json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & tbl(r, c)
                 Else
-                    'test if item is a json object
-                    If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
-                        json = json & """" & tbl(LBound(tbl, 2), c) & """" & ":" & tbl(r, c)
+                    If Left(tbl(r, c), 1) = "{" Or Left(tbl(r, c), 1) = "[" Then
+                        json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & tbl(r, c)
                     Else
-                        json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                        json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & Chr(34) & Replace(tbl(r, c), Chr(34), Chr(34) & Chr(34)) & Chr(34)
                     End If
                 End If
             End If
@@ -3153,3 +3210,178 @@ Sub frmListBoxHeader(ByRef hdr As MSForms.ListBox, ByRef det As MSForms.ListBox,
 End Sub
 
 
+Function TBLp_StackAndUnique(ByRef tbl1() As String, ByRef tbl2() As String, Optional keyColumns As Variant) As String()
+    Dim dict As Object
+    Set dict = CreateObject("Scripting.Dictionary")
+    
+    Dim i As Long, j As Long
+    Dim key As String
+    Dim colCount As Long
+    Dim combined() As String
+    Dim rowIndex As Long
+    Dim out() As String
+    Dim kCols As Variant
+
+    ' === Determine number of columns ===
+    colCount = UBound(tbl1, 1) + 1
+
+    ' === Decide which columns define uniqueness ===
+    If IsMissing(keyColumns) Then
+        ReDim kCols(colCount - 1)
+        For j = 0 To colCount - 1
+            kCols(j) = j
+        Next j
+    Else
+        kCols = keyColumns
+    End If
+
+    ' === Prepare output array with enough space ===
+    Dim totalRows As Long
+    totalRows = (UBound(tbl1, 2) + UBound(tbl2, 2)) + 2 ' +2 for header + safety
+    ReDim combined(colCount - 1, totalRows - 1)
+    
+    rowIndex = 0
+
+    ' === 1. Copy header from tbl1 ===
+    For j = 0 To colCount - 1
+        combined(j, rowIndex) = tbl1(j, 0)
+    Next j
+    rowIndex = rowIndex + 1
+
+    ' === 2. Add data rows from tbl1 ===
+    For i = 1 To UBound(tbl1, 2)
+        key = ""
+        For j = LBound(kCols) To UBound(kCols)
+            key = key & "|" & tbl1(kCols(j), i)
+        Next j
+        If Not dict.exists(key) Then
+            dict.Add key, rowIndex
+            For j = 0 To colCount - 1
+                combined(j, rowIndex) = tbl1(j, i)
+            Next j
+            rowIndex = rowIndex + 1
+        End If
+    Next i
+    
+    ' === 3. Add data rows from tbl2 ===
+    For i = 1 To UBound(tbl2, 2)
+        key = ""
+        For j = LBound(kCols) To UBound(kCols)
+            key = key & "|" & tbl2(kCols(j), i)
+        Next j
+        If Not dict.exists(key) Then
+            dict.Add key, rowIndex
+            For j = 0 To colCount - 1
+                combined(j, rowIndex) = tbl2(j, i)
+            Next j
+            rowIndex = rowIndex + 1
+        End If
+    Next i
+
+    ' === 4. Trim final output ===
+    ReDim out(colCount - 1, rowIndex - 1)
+    For i = 0 To rowIndex - 1
+        For j = 0 To colCount - 1
+            out(j, i) = combined(j, i)
+        Next j
+    Next i
+
+    TBLp_StackAndUnique = out
+End Function
+
+
+Function TBLp_MergePreferValueWithHeader(tbl1() As String, tbl2() As String, _
+                                          keyColumns As Variant, valColumn As Long) As String()
+    Dim dict As Object
+    Set dict = CreateObject("Scripting.Dictionary")
+
+    Dim i As Long, j As Long
+    Dim key As String
+    Dim colCount As Long
+    Dim result() As String
+    Dim rowIndex As Long
+    Dim combined() As String
+    Dim candidate() As String
+
+    ' === Determine number of columns ===
+    colCount = UBound(tbl1, 1) + 1
+
+    ' === Prepare combined big-enough array ===
+    Dim totalRows As Long
+    totalRows = (UBound(tbl1, 2) + UBound(tbl2, 2)) + 2
+    ReDim combined(colCount - 1, totalRows - 1)
+
+    rowIndex = 0
+
+    ' === 1. Copy header ===
+    For j = 0 To colCount - 1
+        combined(j, rowIndex) = tbl1(j, 0)
+    Next j
+    rowIndex = rowIndex + 1
+
+    ' === 2. Process both tables ===
+    For i = 1 To UBound(tbl1, 2)
+        Call AddOrPrefer(dict, combined, rowIndex, tbl1, i, keyColumns, valColumn)
+    Next i
+
+    For i = 1 To UBound(tbl2, 2)
+        Call AddOrPrefer(dict, combined, rowIndex, tbl2, i, keyColumns, valColumn)
+    Next i
+
+    ' === 3. Trim output ===
+    ReDim result(colCount - 1, rowIndex - 1)
+    For i = 0 To rowIndex - 1
+        For j = 0 To colCount - 1
+            result(j, i) = combined(j, i)
+        Next j
+    Next i
+
+    TBLp_MergePreferValueWithHeader = result
+End Function
+
+Private Sub AddOrPrefer(ByRef dict As Object, ByRef combined() As String, ByRef rowIndex As Long, _
+                         ByRef table() As String, ByVal sourceRow As Long, _
+                         ByVal keyColumns As Variant, ByVal valColumn As Long)
+    Dim j As Long
+    Dim key As String
+    Dim candidateVal As String
+    Dim existingRow As Long
+
+    ' Build key
+    key = ""
+    For j = LBound(keyColumns) To UBound(keyColumns)
+        key = key & "|" & table(keyColumns(j), sourceRow)
+    Next j
+
+    candidateVal = trim(table(valColumn, sourceRow))
+
+    If dict.exists(key) Then
+        existingRow = dict(key)
+        ' Decide if new row is "better"
+        If IsBetterValue(candidateVal, combined(valColumn, existingRow)) Then
+            ' Replace existing row
+            For j = 0 To UBound(table, 1)
+                combined(j, existingRow) = table(j, sourceRow)
+            Next j
+        End If
+    Else
+        ' Add new unique row
+        dict.Add key, rowIndex
+        For j = 0 To UBound(table, 1)
+            combined(j, rowIndex) = table(j, sourceRow)
+        Next j
+        rowIndex = rowIndex + 1
+    End If
+End Sub
+
+Private Function IsBetterValue(newVal As String, existingVal As String) As Boolean
+    If existingVal = "" Or existingVal = "-" Then
+        If newVal <> "" And newVal <> "-" Then
+            IsBetterValue = True
+            Exit Function
+        End If
+    End If
+    IsBetterValue = False
+End Function
+
+