From 4dc88d8faf7a19f1d0d77f46cd08291229c332f5 Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Fri, 1 Apr 2022 16:31:23 -0400 Subject: [PATCH] plcore upload, and in-spreadsheet evaluation (Extract) --- PriceLists.bas | 350 ++++++++++++++++++++++++++++--------------------- 1 file changed, 202 insertions(+), 148 deletions(-) diff --git a/PriceLists.bas b/PriceLists.bas index 9609f66..2402ab4 100644 --- a/PriceLists.bas +++ b/PriceLists.bas @@ -1,4 +1,6 @@ Attribute VB_Name = "PriceLists" +Option Explicit + Sub extract_price_matrix_suff() '------------------------------------setup------------------------------------------------- @@ -6,8 +8,15 @@ Sub extract_price_matrix_suff() Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant + Dim lists() As String + Dim pcol() As Long Dim unp() As String Dim unv() As Variant + Dim onelist() As String + Dim i As Long + Dim l As Long + Dim j As Long + Dim unps() As String Dim sql As String Dim error As String @@ -18,177 +27,116 @@ Sub extract_price_matrix_suff() Dim new_sh As Worksheet Dim ws As Worksheet Dim cp As CustomProperty - - '------------------------------------selection------------------------------------------------- - + Set ini = Application.Selection - Selection.CurrentRegion.Select - Set orig = Application.Selection - '--------------------------------test if valid price matrix------------------------------ + unp = unpivot_current_sheet(lists, pcol) - If Selection.Cells.Count = 1 Then - MsgBox ("selection is not a table") - orig.Select - Exit Sub - End If - - tbl = Selection - - If UBound(tbl, 1) < 2 Then error = "selection is not a valid price matrix" - If UBound(tbl, 2) <> 9 Then error = "selection is not a valid price matrix" - - If Not error = "" Then - MsgBox (error) - Exit Sub - End If - - '-----------------------------unpivot price matrix into new array----------------------------- - - Dim i As Long - Dim j As Long - Dim k As Long - Dim m As Long - k = 0 - ReDim unp(9, (UBound(tbl, 1) - 1) * 3) - 'iterate through rows - For i = 2 To UBound(tbl, 1) - '3 iterations per row - For m = 0 To 2 - k = k + 1 - 'part - unp(0, k) = tbl(i, 1) 'stlye code - unp(1, k) = tbl(i, 2) 'color tier - unp(2, k) = tbl(i, 3) 'branding - unp(3, k) = tbl(i, 4) 'kit - unp(4, k) = tbl(i, 5) 'suffix - unp(5, k) = tbl(i, 6) 'container - unp(6, k) = m + 1 'volume break - unp(7, k) = tbl(i, 7 + m) 'price - unp(8, k) = i 'orig row - unp(9, k) = 7 + m 'orig col - Next m - Next i - unp(0, 0) = "stlc" - unp(1, 0) = "coltier" - unp(2, 0) = "branding" - unp(3, 0) = "accs" - unp(4, 0) = "suffix" - unp(5, 0) = "container" - unp(6, 0) = "volume" - unp(7, 0) = "price" - unp(8, 0) = "orig_row" - unp(9, 0) = "orig_col" - - - If Not x.TBLp_TestNumeric(unp, 7) Then - MsgBox ("price is text") - Exit Sub - End If - - unp = x.TBLp_Transpose(unp) - unv = x.TBLp_StringToVar(unp) - - '-------------------------prepare sql to upload--------------------------------------------------------------- - - 'sql = x.SQLp_build_sql_values(unp, False, True, Db2, False) - sql = x.json_from_table(unv, "", False) - sql = "SELECT * FROM rlarp.build_f20_suff($$" & sql & "$$::jsonb)" - Call wapi.ClipBoard_SetData(sql) - - 'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub - 'Exit Sub login.Show If Not login.proceed Then Exit Sub - If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") Then MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) Exit Sub End If - cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True) - - Call x.ADOp_CloseCon(0) - - 'Exit Sub - - '--------------------------setup an output sheet if necessary------------------------------- - - For Each ws In Application.Worksheets - For Each cp In ws.CustomProperties - If cp.Name = "spec_name" And cp.value = "price_list" Then - Set new_sh = ws - Exit For - End If - Next cp - Next ws - - 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------------------------------------------------------ - - Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) - new_sh.Select - ActiveSheet.Cells(1, 1).CurrentRegion.Select - Selection.Columns.AutoFit - - Rows("1:1").Select - With ActiveWindow - .SplitColumn = 0 - .SplitRow = 1 - End With - ActiveWindow.FreezePanes = True - - - '--------------------------format source cells for any build issues-------------------------------- - - orig.Worksheet.Select - With orig.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With - 'if a cell has even one valid hit, don't show an error - 'create a copy of tbl - 'the default value for cell is error, if any good values are found, they stay + For l = 1 To UBound(lists) + '----------filter the main data set for each price lists (due to json_from_table taking forever on big tables)-------- + onelist = unp + Call x.TBLp_FilterSingle(onelist, 9, lists(l), True) + onelist = x.TBLp_Transpose(onelist) + unv = x.TBLp_StringToVar(onelist) - j = 0 - For i = 1 To UBound(cms_pl, 1) - Select Case cms_pl(i, 15) - Case "" - orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6 - Case "No UOM Conversion" - 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) + '-------------------------prepare sql to upload--------------------------------------------------------------- + + 'sql = x.SQLp_build_sql_values(unp, False, True, Db2, False) + sql = x.json_from_table(unv, "", False) + sql = "SELECT * FROM rlarp.plcore_fullcode_inq($$" & sql & "$$::jsonb)" + Call wapi.ClipBoard_SetData(sql) + + 'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub + 'Exit Sub + cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True) + + '--------------------------setup an output sheet if necessary------------------------------- + + For Each ws In Application.Worksheets + For Each cp In ws.CustomProperties + If cp.Name = "spec_name" And cp.value = "price_list" Then + Set new_sh = ws + Exit For End If - Case "Inactive" - 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, 20, 161) - End If - Case "No SKU" - 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(20, 255, 161) - End If - End Select - 'if the current row/column is OK, advance to the next row/column + Next cp + Next ws + + 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------------------------------------------------------ + + Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) + new_sh.Select + ActiveSheet.Cells(1, 1).CurrentRegion.Select + Selection.Columns.AutoFit + + Rows("1:1").Select + With ActiveWindow + .SplitColumn = 0 + .SplitRow = 1 + End With + ActiveWindow.FreezePanes = True + + + '--------------------------format source cells for any build issues-------------------------------- + + orig.Worksheet.Select + 'if a cell has even one valid hit, don't show an error + 'create a copy of tbl + 'the default value for cell is error, if any good values are found, they stay + 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 + For i = 1 To UBound(cms_pl, 1) + Select Case cms_pl(i, 15) + Case "" + orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor = xlThemeColorAccent6 + Case "No UOM Conversion" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 255, 161) + End If + Case "Inactive" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 20, 161) + End If + Case "No SKU" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(20, 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 + + Next l - Dim cell As Range + Call x.ADOp_CloseCon(0) For Each cell In Application.Selection.Cells 'if the cell fill is green, then a known good part was found, so cell to blank @@ -209,6 +157,9 @@ Sub extract_price_matrix_suff() Selection.Columns(5).Interior.Pattern = xlNone Selection.Columns(6).Interior.Pattern = xlNone Selection.Rows(1).Interior.Pattern = xlNone + For i = 1 To UBound(pcol) + Selection.Columns(pcol(i) + 1).Interior.Pattern = xlNone + Next i '----------------------------cleanup------------------------------------------------------------- @@ -469,3 +420,106 @@ PRICELIST_SHOW: End Sub + +Function unpivot_current_sheet(ByRef lists() As String, ByRef pcol() As Long) As String() + + Dim x As New TheBigOne 'function library + Dim sh As Worksheet 'target worksheet + Dim big() As String 'all price lists in one array + Dim unpivot() As String 'unwrap the columns into volume level rows + Dim load() As String 'individual price list to be loaded + Dim pcount As Long 'count of price list + 'Dim pcol() As Long 'hold the positions of each price list + ReDim pcol(30) 'size the array starting with 30 and trim later + ReDim lists(30) + Dim dcol() As Integer 'columns to be deleted + Dim typeflag() As String 'array of column types + Dim i As Long 'walks through each price list + Dim j As Long 'walks through each original row + Dim k As Long 'creates new rows for each price break + Dim m As Long 'row position in the new table + Dim sql As String + + '-------identify the active sheet and load the contents to an array----------- + + Set sh = ActiveSheet + big = x.SHTp_Get(sh.Name, 3, 1, True) + + '------iterate through the column headers to identify the price lists--------- + + pcount = 0 + For i = 0 To UBound(big, 1) + If big(i, 0) = "plist" Then + pcount = pcount + 1 + pcol(pcount) = i + lists(pcount) = big(i, 1) + End If + Next i + + '------if no columns are labeled plist then exit------------------------------ + + If pcount = 0 Then Exit Function + ReDim Preserve pcol(pcount) + ReDim Preserve lists(pcount) + ReDim typeflag(9) + + + '----since there are 3 price columns, those will need transformed to 3 price rows per each original----- + ReDim load(11, UBound(big, 2) * 3 * pcount) + m = 1 + '----set headers----- + load(0, 0) = "stlc" + load(1, 0) = "coltier" + load(2, 0) = "branding" + load(3, 0) = "accs" + load(4, 0) = "suffix" + load(5, 0) = "uomp" + load(6, 0) = "vol_uom" + load(7, 0) = "vol_qty" + load(8, 0) = "vol_price" + load(9, 0) = "listcode" + load(10, 0) = "orig_row" + load(11, 0) = "orig_col" + + For pcount = 1 To UBound(pcol) + '-----populate------------ + For i = 1 To UBound(big, 2) + '-----hard coded to number of price breaks (3)------- + For k = 0 To 2 + load(0, m) = big(0, i) + load(1, m) = big(1, i) + load(2, m) = big(2, i) + load(3, m) = big(3, i) + load(4, m) = big(4, i) + '----position 3 is a bulk pallet so the default UOM needs hard coded to PLT----- + If k = 2 Then + load(5, m) = "PLT" + Else + load(5, m) = big(5, i) + End If + '----(3-k) should work out to 1st 2nd 3rd price colum---------------------------- + '----the first column UOM is the default package, everything else is a pallet---- + If k = 0 Then + load(6, m) = big(5, i) + Else + load(6, m) = "PLT" + End If + '----for now the volumes are always 1 of the unit of measure in colunm 6 above + load(7, m) = "1" + load(8, m) = Format(big(pcol(pcount) - (3 - k), i), "####0.00") + load(9, m) = big(pcol(pcount) - 0, i) + load(10, m) = i + load(11, m) = pcol(pcount) - (3 - k) + m = m + 1 + Next k + Next i + Next pcount + + If Not x.TBLp_TestNumeric(load, 8) Then + MsgBox ("price is text") + Exit Function + End If + + unpivot_current_sheet = load + +End Function