diff --git a/FL.bas b/FL.bas index efe152e..7ac3ef2 100644 --- a/FL.bas +++ b/FL.bas @@ -1185,6 +1185,207 @@ Sub extract_price_matrix_r1() End Sub +Sub extract_price_matrix_r2() + + '------------------------------------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 cms_pl() As String + Dim pw As String + Dim new_sh As Worksheet + Dim ws As Worksheet + Dim cp As CustomProperty + + '------------------------------------selection------------------------------------------------- + + Set orig = 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) = j + m 'orig col + Next m + Next i + unp(0, 0) = "stlc" + unp(1, 0) = "coltier" + unp(2, 0) = "branding" + unp(3, 0) = "kit" + 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_pricelist_r1($$" & sql & "$$::jsonb)" + Call wapi.ClipBoard_SetData(sql) + + If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then 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) + + '--------------------------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") + 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 + + Exit Sub + 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 i = 1 To UBound(cms_pl, 1) + Select Case cms_pl(i, 13) + Case "" + orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor = xlThemeColorAccent6 + Case "no unit conversion" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + End If + Case "no part number" + If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then + orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161) + End If + End Select + 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.Rows(1).Interior.Pattern = xlNone + Selection.Rows(2).Interior.Pattern = xlNone + Selection.Rows(3).Interior.Pattern = xlNone + + '----------------------------cleanup------------------------------------------------------------- + + Set x = Nothing + +End Sub + Sub go_to_price_issue() Dim ws As Worksheet