create new isolated module for working with price lists
This commit is contained in:
parent
3ce9b371ca
commit
eb630686aa
|
|
@ -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
|
||||
Loading…
Reference in New Issue