From 4311b3b3e4c9870dcce7c878357eba2864fdd476 Mon Sep 17 00:00:00 2001 From: pt Date: Thu, 9 Jan 2020 17:53:00 -0500 Subject: [PATCH] build price list functionality --- FL.bas | 242 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 241 insertions(+), 1 deletion(-) diff --git a/FL.bas b/FL.bas index 700a280..1278ede 100644 --- a/FL.bas +++ b/FL.bas @@ -1,5 +1,6 @@ Option Explicit +Public price_sheet As Worksheet Public x As New TheBigOne @@ -253,6 +254,7 @@ Function json_from_list(keys As range, values As range) As String Dim i As Integer Dim first_comma As Boolean Dim needs_braces As Integer + Dim needs_comma As Boolean needs_comma = False needs_braces = 0 @@ -276,6 +278,12 @@ Function json_from_list(keys As range, values As range) As String End Function +Function json_nest(key As String, json As String) As String + + json_nest = "{""" & key & """:" & json & "}" + +End Function + Function json_concat(list As range) As String Dim json As String @@ -306,6 +314,7 @@ Sub json_from_table_pretty() Dim x As New TheBigOne Dim tbl() As Variant + Selection.CurrentRegion.Select tbl = Selection Dim ajson As String @@ -357,6 +366,7 @@ Sub json_from_table() Dim tbl() As Variant + Selection.CurrentRegion.Select tbl = Selection Call wapi.ClipBoard_SetData(x.json_from_table(tbl, "y", False)) @@ -555,6 +565,7 @@ Sub markdown_from_table() Dim wapi As New Windows_API Dim tbl() As Variant + Selection.CurrentRegion.Select tbl = Selection Call wapi.ClipBoard_SetData(x.markdown_from_table(tbl)) @@ -589,7 +600,7 @@ Sub sql_from_range() Dim x As New TheBigOne Dim wapi As New Windows_API Dim r() As String - + Selection.CurrentRegion.Select Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2)) End Sub @@ -672,4 +683,233 @@ Sub split_forecast_data() +End Sub + +Function range_empty(ByRef r As range) As Boolean + + Dim c As range + range_empty = True + + For Each c In r.Cells + If Not IsEmpty(c.value) Then + range_empty = False + Exit Function + End If + Next c + +End Function + +Function build_monthly(ByRef part As String, billto_group As String, month As String, vol As Double, amt As Double) As String + + Dim j As Object + + Set j("part") = part + Set j("billto_group") = billto_group + Set j("month") = month + Set j("part") = vol + Set j("part") = amt + + build_monthly = JsonConverter.ConvertToJson(j) + +End Function + +Sub extract_price_matrix() + + '------------------------------------setup------------------------------------------------- + + Dim wapi As New Windows_API + Dim x As New TheBigOne + Dim tbl() As Variant + Dim unp() As String + 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) < 4 Then error = "selection is not a valid price matrix" + If UBound(tbl, 2) < 2 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 + k = 0 + ReDim unp(7, (UBound(tbl, 2) - 1) * (UBound(tbl, 1) - 3)) + For i = 4 To UBound(tbl, 1) + For j = 2 To UBound(tbl, 2) + k = k + 1 + 'part + unp(0, k) = tbl(i, 1) + 'copy headers down the left + unp(1, k) = tbl(1, j) 'size code (row one, column j) + unp(2, k) = tbl(2, j) 'volue break uom (row 2, column j) + unp(3, k) = Format(tbl(3, j), "#.00") 'volue break qty (row 3, column j) + unp(4, k) = "M" 'pricing unit of measuer + unp(5, k) = Format(tbl(i, j), "#.00") 'price (row i, column j) + unp(6, k) = i + unp(7, k) = j + Next j + Next i + unp(0, 0) = "mold" + unp(1, 0) = "sizc" + unp(2, 0) = "vbuom" + unp(3, 0) = "vbqty" + unp(4, 0) = "puom" + unp(5, 0) = "price" + unp(6, 0) = "orig_row" + unp(7, 0) = "orig_col" + + + '-------------------------prepare sql to upload--------------------------------------------------------------- + + sql = x.SQLp_build_sql_values(unp, False, True, Db2) + sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA" + Call wapi.ClipBoard_SetData(sql) + + login.Show + If Not login.proceed Then Exit Sub + + + If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then + MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) + Exit Sub + End If + + If Not x.ADOp_Exec(0, sql) Then + MsgBox (x.ADOo_errstring) + Call x.ADOp_CloseCon(0) + Exit Sub + End If + + '-------------------call price build procedure-------------------------------------------------------- + + cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True) + + Call x.ADOp_CloseCon(0) + + If x.ADOo_errstring <> "" Then + MsgBox (x.ADOo_errstring) + Exit Sub + End If + + '--------------------------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 + 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 + + With orig.Interior + .Pattern = xlNone + .TintAndShade = 0 + .PatternTintAndShade = 0 + End With + + For i = 1 To UBound(cms_pl, 1) + Select Case cms_pl(i, 9) + Case "" + Case "no unit conversion" + orig.Worksheet.Cells(orig.row + cms_pl(i, 10) - 1, orig.column + cms_pl(i, 11) - 1).Interior.Color = RGB(255, 255, 161) + Case "no part number" + orig.Worksheet.Cells(orig.row + cms_pl(i, 10) - 1, orig.column + cms_pl(i, 11) - 1).Interior.Color = RGB(220, 220, 220) + End Select + Next i + + '----------------------------cleanup------------------------------------------------------------- + + Set x = Nothing + +End Sub + +Sub go_to_price_issue() + + Dim ws As Worksheet + Dim cp As CustomProperty + Dim orig As range + Dim trow As Long + Dim tcol As Long + Dim i As Long + + For Each ws In Application.Worksheets + For Each cp In ws.CustomProperties + If cp.Name = "spec_name" And cp.value = "price_list" Then + Set price_sheet = ws + End If + Next cp + Next ws + + Set orig = Application.Selection + + Selection.CurrentRegion.Select + + + trow = orig.row - Selection.row + 1 + tcol = orig.column - Selection.column + 1 + + i = 1 + Do Until price_sheet.Cells(i, 1) = "" + If price_sheet.Cells(i, 11) = trow And price_sheet.Cells(i, 12) = tcol Then + price_sheet.Select + ActiveSheet.Cells(i, 10).Select + Exit Sub + End If + i = i + 1 + Loop + + End Sub