Attribute VB_Name = "PriceLists" Sub extract_price_matrix_suff() '------------------------------------setup------------------------------------------------- Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant Dim unp() As String Dim unv() As Variant Dim unps() As String Dim sql As String Dim error As String Dim orig As Range Dim ini As Range Dim cms_pl() As String Dim pw As String 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------------------------------ 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 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) 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 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 For Each cell In Application.Selection.Cells 'if the cell fill is green, then a known good part was found, so cell to blank If cell.Interior.ThemeColor = xlThemeColorAccent6 Then cell.Interior.Pattern = xlNone Else If cell.Interior.Pattern = xlNone And cell.value <> "" Then cell.Interior.Color = RGB(255, 255, 161) End If End If 'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed Next cell 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 '----------------------------cleanup------------------------------------------------------------- Set x = Nothing ini.Select End Sub Sub price_load_plcore() 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 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 End If Next i '------if no columns are labeled plist then exit------------------------------ If pcount = 0 Then Exit Sub ReDim Preserve pcol(pcount) ReDim typeflag(9) If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then MsgBox (Err.Description) Exit Sub End If '------prepare upload for each price list------------------------------------- typeflag(0) = "S" typeflag(1) = "S" typeflag(2) = "S" typeflag(3) = "S" typeflag(4) = "S" typeflag(5) = "S" typeflag(6) = "S" typeflag(7) = "N" typeflag(8) = "N" typeflag(9) = "S" For pcount = 1 To UBound(pcol) '----since there are 3 price columns, those will need transformed to 3 price rows per each original----- ReDim load(9, UBound(big, 2) * 3) '----set headers----- load(0, 0) = "stlc" load(1, 0) = "coltier" load(2, 0) = "branding" load(3, 0) = "accs" load(4, 0) = "suff" load(5, 0) = "uomp" load(6, 0) = "vol_uom" load(7, 0) = "vol_qty" load(8, 0) = "vol_price" load(9, 0) = "listcode" '-----populate------------ m = 1 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) m = m + 1 Next k Next i '------build insert statement for target price list----- sql = "BEGIN;" sql = sql & vbCrLf & "DELETE FROM rlarp.plcore WHERE listcode = '" & load(9, 1) & "';" sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S") & ";" sql = sql & vbCrLf & "COMMIT;" '------do the insert------------------------------------ If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If Next pcount Call x.ADOp_CloseCon(0) End Sub Sub build_price_upload_suff() 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 '--------------remove any lines with errors------------- If Not pricelist.cbInactive Then Call x.TBLp_FilterSingle(pl, 16, "", True) End If '--------------remove empty price lines----------------- Call x.TBLp_FilterSingle(pl, 13, "", False) 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