create new isolated module for working with price lists

This commit is contained in:
Paul Trowbridge 2022-03-31 17:39:08 -04:00
parent 3ce9b371ca
commit eb630686aa

471
PriceLists.bas Normal file
View File

@ -0,0 +1,471 @@
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