From 5928c83a24071dff4d48a776569c83d02ef4f70d Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Thu, 10 Jul 2025 21:59:06 -0400 Subject: [PATCH] changes made during target price rebuild --- TheBigOne.cls | 186 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 180 insertions(+), 6 deletions(-) diff --git a/TheBigOne.cls b/TheBigOne.cls index 47d6799..9f4f538 100644 --- a/TheBigOne.cls +++ b/TheBigOne.cls @@ -2304,7 +2304,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 +2324,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 +3152,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 + +