diff --git a/FL.bas b/FL.bas index 7ac3ef2..e0ee11c 100644 --- a/FL.bas +++ b/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 - orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + 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, 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 - orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + 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, 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 - orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + 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, 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 - orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + 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, 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 diff --git a/TheBigOne.cls b/TheBigOne.cls index cb811a7..c403f9b 100644 --- a/TheBigOne.cls +++ b/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 c = 1 To UBound(tbl, 2) + For r = LBound(tbl, 1) + 1 To UBound(tbl, 1) + 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 j = 1 To UBound(t, 1) + For i = LBound(t, 2) To UBound(t, 2) + 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 +