plcore upload, and in-spreadsheet evaluation (Extract)

This commit is contained in:
Paul Trowbridge 2022-04-01 16:31:23 -04:00
parent eb630686aa
commit 4dc88d8faf

View File

@ -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
@ -19,176 +28,115 @@ Sub extract_price_matrix_suff()
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
Dim cell As Range
Next l
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