updates

FL.bas

@@ -1,4 +1,5 @@
 Attribute VB_Name = "FL"
+
 Option Explicit
 
 Public price_sheet As Worksheet
@@ -419,6 +420,7 @@ End Sub
 Sub PastValues()
 Attribute PastValues.VB_ProcData.VB_Invoke_Func = "V\n14"
 
+
 On Error GoTo errh
 
     Call Selection.PasteSpecial(xlPasteValues, xlNone, False, False)
@@ -431,6 +433,7 @@ End Sub
 Sub CollapsePvtItem()
 Attribute CollapsePvtItem.VB_ProcData.VB_Invoke_Func = "Z\n14"
 
+
 On Error GoTo show_det
     ActiveCell.PivotItem.DrilledDown = False
     
@@ -459,6 +462,7 @@ End Sub
 Sub ExpandPvtItem()
 Attribute ExpandPvtItem.VB_ProcData.VB_Invoke_Func = "X\n14"
 
+
 On Error GoTo show_det
     ActiveCell.PivotItem.DrilledDown = True
     
@@ -487,6 +491,7 @@ End Sub
 Sub CollapsePvtFld()
 Attribute CollapsePvtFld.VB_ProcData.VB_Invoke_Func = "A\n14"
 
+
 On Error GoTo show_det
     ActiveCell.PivotField.DrilledDown = False
     
@@ -516,6 +521,7 @@ End Sub
 Sub ExpandPvtFld()
 Attribute ExpandPvtFld.VB_ProcData.VB_Invoke_Func = "S\n14"
 
+
 On Error GoTo show_det
     ActiveCell.PivotField.DrilledDown = True
     
@@ -596,6 +602,10 @@ Sub SetPivotShortcutKeys()
     Call Application.MacroOptions("PERSONAL.xlsb!CollapsePvtItem", "", , , , "Z")
     Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtFld", "", , , , "S")
     Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtItem", "", , , , "X")
+    Call Application.MacroOptions("PERSONAL.xlsb!PastValues", "", , , , "V")
+    Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format", "", , , , "F")
+    Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format_3dec", "", , , , "N")
+    Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format_1dec", "", , , , "M")
 
 End Sub
 
@@ -703,6 +713,13 @@ Attribute pivot_field_format_3dec.VB_ProcData.VB_Invoke_Func = "N\n14"
 
 End Sub
 
+Sub pivot_field_format_1dec()
+Attribute pivot_field_format_1dec.VB_ProcData.VB_Invoke_Func = "M\n14"
+
+    ActiveSheet.PivotTables(1).PivotFields(ActiveCell.value).NumberFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""???_);_(@_)"
+
+End Sub
+
 Sub Write_selection()
     Dim P As FileDialog
 
@@ -964,9 +981,9 @@ Sub extract_price_matrix()
         Select Case cms_pl(i, 13)
             Case ""
             Case "no unit conversion"
-                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
             Case "no part number"
-                'orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
+                'orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(220, 220, 220)
         End Select
     Next i
     
@@ -1147,14 +1164,14 @@ Sub extract_price_matrix_r1()
     For i = 1 To UBound(cms_pl, 1)
         Select Case cms_pl(i, 13)
             Case ""
-                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor = xlThemeColorAccent6
+                orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
             Case "no unit conversion"
-                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
-                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
                 End If
             Case "no part number"
-                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
-                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
                 End If
         End Select
     Next i
@@ -1253,7 +1270,7 @@ Sub extract_price_matrix_r2()
             unp(6, k) = m + 1                       'volume break
             unp(7, k) = tbl(i, 7 + m)               'price
             unp(8, k) = i                           'orig row
-            unp(9, k) = j + m                       'orig col
+            unp(9, k) = 7 + m                       'orig col
         Next m
     Next i
     unp(0, 0) = "stlc"
@@ -1283,7 +1300,7 @@ Sub extract_price_matrix_r2()
     sql = "SELECT * FROM rlarp.build_pricelist_r1($$" & sql & "$$::jsonb)"
     Call wapi.ClipBoard_SetData(sql)
     
-    If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
+    'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
     
     login.Show
     If Not login.proceed Then Exit Sub
@@ -1312,6 +1329,7 @@ Sub extract_price_matrix_r2()
     If new_sh Is Nothing Then
         Set new_sh = Application.Worksheets.Add
         Call new_sh.CustomProperties.Add("spec_name", "price_list")
+        new_sh.Name = "Price Build"
     End If
     
     '-------------------------dump contents------------------------------------------------------
@@ -1333,7 +1351,6 @@ Sub extract_price_matrix_r2()
     
     orig.Worksheet.Select
     
-    Exit Sub
     With orig.Interior
         .Pattern = xlNone
         .TintAndShade = 0
@@ -1344,20 +1361,27 @@ Sub extract_price_matrix_r2()
     'create a copy of tbl
     'the default value for cell is error, if any good values are found, they stay
     
-    
+    j = 0
     For i = 1 To UBound(cms_pl, 1)
-        Select Case cms_pl(i, 13)
+        Select Case cms_pl(i, 15)
             Case ""
-                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor = xlThemeColorAccent6
+                orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
             Case "no unit conversion"
-                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
-                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
                 End If
             Case "no part number"
-                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
-                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
                 End If
         End Select
+        'if the current row/column is OK, advance to the next row/column
+        j = 0
+        Do Until cms_pl(i, 13) <> cms_pl(i + j, 13) Or cms_pl(i, 14) <> cms_pl(i + j, 14)
+            j = j + 1
+            If i + j >= UBound(cms_pl, 1) Then Exit Do
+        Loop
+        i = i + j - 1 '-1 becuase the "next i" will increment by 1 again
     Next i
     
     Dim cell As Range
@@ -1376,9 +1400,12 @@ Sub extract_price_matrix_r2()
     
     Selection.Columns(1).Interior.Pattern = xlNone
     Selection.Columns(2).Interior.Pattern = xlNone
+    Selection.Columns(3).Interior.Pattern = xlNone
+    Selection.Columns(4).Interior.Pattern = xlNone
+    Selection.Columns(5).Interior.Pattern = xlNone
+    Selection.Columns(6).Interior.Pattern = xlNone
     Selection.Rows(1).Interior.Pattern = xlNone
-    Selection.Rows(2).Interior.Pattern = xlNone
+
-    Selection.Rows(3).Interior.Pattern = xlNone
     
     '----------------------------cleanup-------------------------------------------------------------
     
@@ -1547,3 +1574,128 @@ PRICELIST_SHOW:
 
 End Sub
 
+
+
+Sub build_price_upload_r2()
+
+    Dim x As New TheBigOne
+    Dim pl() As String
+    Dim plv() As Variant
+    Dim i As Long
+    Dim j As Long
+    Dim ul() As String
+    Dim pl_code As String
+    Dim pl_action As String
+    Dim dtl_action As String
+    Dim pl_d1 As String
+    Dim pl_d2 As String
+    Dim pl_d3 As String
+    Dim fd As FileDialog
+    Dim ulsql As String
+    Dim temp() As String
+    Dim wapi As New Windows_API
+    
+    
+    pl = x.SHTp_GetString(Selection)
+    ReDim ul(11, UBound(pl, 2))
+    
+PRICELIST_SHOW:
+    
+    Call pricelist.load_lists
+    
+    pricelist.Show
+    
+    If Not pricelist.proceed Then Exit Sub
+    
+    pl_code = pricelist.cbLIST.value
+    pl_d1 = pricelist.tbD1.Text
+    pl_d2 = pricelist.tbD2.Text
+    pl_d3 = pricelist.tbD3.Text
+    pl_action = Mid(pricelist.cbHDR.value, 1, 1)
+    dtl_action = Mid(pricelist.cbDTL.value, 1, 1)
+    
+    
+    If Len(pricelist.cbLIST.value) > 5 Then
+        MsgBox ("price code must be 5 or less characters")
+        GoTo PRICELIST_SHOW
+    End If
+    
+    If Not pricelist.cbInactive Then
+        Call x.TBLp_FilterSingle(pl, 11, "I", False)
+    End If
+    
+    If Not pricelist.cbNonStocked Then
+        Call x.TBLp_FilterSingle(pl, 8, "A", True)
+    End If
+    
+    'need to get the current list of products and if they already exist for the target price list
+    'target price list
+    'target part
+    'target volume level
+    
+    
+    'ulsql = FL.x.SQLp_build_sql_values(pl, True, True, PostgreSQL, False)
+    'pl = x.TBLp_Transpose(pl)
+    'plv = x.TBLp_StringToVar(pl)
+    'ulsql = x.json_from_table(plv, "")
+    'ulsql = "DECLARE GLOBAL TEMPORARY TABLE session.plb AS (" & ulsql & ") WITH DATA"
+'    If login.tbP.Text = "" Then
+'        login.Show
+'        If Not login.proceed Then
+'            Exit Sub
+'        End If
+'    End If
+    'Call wapi.ClipBoard_SetData(ulsql)
+    'Exit Sub
+
+    'If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then
+    '    MsgBox (FL.x.ADOo_errstring)
+    '    Exit Sub
+    'End If
+    
+    'pl = FL.x.ADOp_SelectS(0, "SELECT p.*, CASE WHEN COALESCE(c.jcpart,'') = '' THEN '1' ELSE '2' END flag FROM Session.plb P LEFT OUTER JOIN lgdat.iprcc c ON c.jcpart = P.Item AND c.JCPLCD = '" & pl_code & "' AND c.JCVOLL = p.vbqty * cast(p.num as float) / cast(p.den as float)", True, 10000, True)
+    'If Not FL.x.ADOp_Exec(0, "DROP TABLE SESSION.PLB", 1, True, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then
+    '    MsgBox (FL.x.ADOo_errstring)
+    '    Exit Sub
+    'End If
+    'Call FL.x.ADOp_CloseCon(0)
+    
+    
+    ul(0, 0) = "HDR"
+    ul(1, 0) = pl_action
+    ul(2, 0) = pl_code
+    ul(3, 0) = Left(pl_d1, 30)
+    ul(4, 0) = Left(pl_d2, 30)
+    ul(5, 0) = Left(pl_d3, 30)
+    ul(6, 0) = "Y"
+    ul(7, 0) = "N"
+    j = 0
+    For i = LBound(pl, 2) + 1 To UBound(pl, 2)
+        'if there is no [uom, part#, price], don't create a row
+        If pl(11, i) <> "" And pl(7, i) <> "" And pl(6, i) <> "" And pl(13, i) <> "" Then
+            j = j + 1
+            ul(0, j) = "DTL"                                                                'DTL
+            ul(1, j) = pl_code                                                              'Price list code
+            ul(2, j) = pl(6, i)                                                             'part number
+            ul(3, j) = pl(12, i)                                                            'price unit
+            ul(4, j) = Format(pl(11, i), "0.00000")                                            'volume break in price uom
+            ul(5, j) = Format(pl(13, i), "0.00000")                                            'price
+            ul(11, j) = dtl_action                                                          'add, update, delete
+        End If
+    Next i
+    
+    ReDim Preserve ul(11, j)
+
+    
+    '--------Open file-------------
+    
+    If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then
+        MsgBox ("error")
+    End If
+    
+    'Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv")
+    
+    '---------------------header row---------------------------------
+    
+
+End Sub

TheBigOne.cls

@@ -7,7 +7,6 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = False
 Attribute VB_Exposed = False
-
 Option Explicit
 
 Private ADOo_con() As ADODB.Connection
@@ -1498,11 +1497,11 @@ End Function
 Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean
     
     Application.EnableCancelKey = xlDisabled
-    MsgB.tbMSG.text = Message
+    MsgB.tbMSG.Text = Message
     MsgB.Caption = TITLE
     MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
     MsgB.Show
-    MISC_msgbox_cancel = MsgB.Cancel
+    MISC_msgbox_cancel = MsgB.cancel
     Application.EnableCancelKey = xlInterrupt
 
 End Function
@@ -2138,20 +2137,20 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
     needs_braces = 0
     ajson = ""
     
-    For r = 2 To UBound(tbl, 1)
+    For r = LBound(tbl, 1) + 1 To UBound(tbl, 1)
-        For c = 1 To UBound(tbl, 2)
+        For c = LBound(tbl, 2) To UBound(tbl, 2)
             If tbl(r, c) <> "" Then
                 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
-                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
+                    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(1, c) & """" & ":" & tbl(r, c)
+                        json = json & """" & tbl(LBound(tbl, 2), c) & """" & ":" & tbl(r, c)
                     Else
-                        json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                        json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
                     End If
                 End If
             End If
@@ -2159,7 +2158,7 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
         If needs_braces > 0 Then json = "{" & json & "}"
         needs_comma = False
         needs_braces = 0
-        If r > 2 Then
+        If r > LBound(tbl, 1) + 1 Then
             ajson = ajson & "," & json
         Else
             ajson = json
@@ -2170,7 +2169,7 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
     'if theres more the one record, include brackets for array
     'if an array_label is given give the array a key and the array become the value
     'then if the array is labeled with a key it should have braces unless specified otherwise
-    If r > 3 Then
+    If r > LBound(tbl, 1) + 2 Then
         ajson = "[" & ajson & "]"
         If array_label <> "" Then
             ajson = """" & array_label & """:" & ajson
@@ -2545,7 +2544,7 @@ Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As Strin
     Dim s As String, tmp As Double, i As Integer, lastI As Integer
     Dim BaseSize As Integer
     BaseSize = Len(sNewBaseDigits)
-    Do While val(d) <> 0
+    Do While Val(d) <> 0
         tmp = d
         i = 0
         Do While tmp >= BaseSize
@@ -2670,8 +2669,8 @@ Function TBLp_Transpose(ByRef t() As String) As String()
     
     ReDim x(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
     
-    For i = 1 To UBound(t, 2)
+    For i = LBound(t, 2) To UBound(t, 2)
-        For j = 1 To UBound(t, 1)
+        For j = LBound(t, 1) To UBound(t, 1)
             x(i, j) = t(j, i)
         Next j
     Next i
@@ -2700,7 +2699,28 @@ Function TBLp_VarToString(ByRef t() As Variant) As String()
 
 End Function
 
-Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
+Function TBLp_StringToVar(ByRef t() As String) As Variant()
+
+    Dim i As Long
+    Dim j As Long
+    Dim x() As Variant
+    
+    If LBound(t, 1) = 1 Then
+    End If
+    
+    ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2))
+    
+    For i = LBound(t, 1) To UBound(t, 1)
+        For j = LBound(t, 2) To UBound(t, 2)
+            x(i, j) = t(i, j)
+        Next j
+    Next i
+
+    TBLp_StringToVar = x
+
+End Function
+
+Sub frmListBoxHeader(ByRef hdr As MSForms.ListBox, ByRef det As MSForms.ListBox, ParamArray cols())
 
     Dim i As Long
 
@@ -2728,3 +2748,4 @@ Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox,
     
 End Sub
 
+