diff --git a/VBA/Utils.bas b/VBA/Utils.bas index b79c52c..4cc22f3 100644 --- a/VBA/Utils.bas +++ b/VBA/Utils.bas @@ -382,15 +382,15 @@ End Function Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer() - Dim x() As Integer + Dim X() As Integer Dim i As Integer - ReDim x(UBound(items)) + ReDim X(UBound(items)) For i = 0 To UBound(items()) - x(i) = items(i) + X(i) = items(i) Next i - ARRAYp_MakeInteger = x + ARRAYp_MakeInteger = X End Function @@ -604,15 +604,17 @@ Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, 'lbHEAD.ZOrder (0) hdr.SpecialEffect = fmSpecialEffectFlat 'hdr.BackColor = RGB(200, 200, 200) - hdr.Height = 10 + 'hdr.Height = 15 ' align header to body (should be done last!) hdr.width = det.width hdr.Left = det.Left - hdr.Top = det.Top - (hdr.Height - 1) + hdr.Top = det.Top - (hdr.Height + 3) End Sub - +Public Function IntersectsWith(Range1 As Range, Range2 As Range) As Boolean + IntersectsWith = Not Application.Intersect(Range1, Range2) Is Nothing +End Function diff --git a/VBA/build.frm b/VBA/build.frm index 054208b..c3de5f4 100644 --- a/VBA/build.frm +++ b/VBA/build.frm @@ -1,10 +1,10 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build - Caption = "UserForm1" - ClientHeight = 3015 + Caption = "Change the Mix" + ClientHeight = 1590 ClientLeft = 120 ClientTop = 465 - ClientWidth = 8100 + ClientWidth = 10725 OleObjectBlob = "build.frx":0000 StartUpPosition = 1 'CenterOwner End @@ -13,61 +13,27 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False -Public part As String -Public bill As String -Public ship As String -Public useval As Boolean Option Explicit -Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - Select Case KeyCode - Case 13 - useval = True - Me.Hide - Case 27 - useval = False - Me.Hide - End Select +Public useval As Boolean + +Private Sub cmdCancel_Click() + useval = False + Me.Hide End Sub - -Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - - Select Case KeyCode - Case 13 - useval = True - Me.Hide - Case 27 - useval = False - Me.Hide - End Select - +Private Sub cmdOK_Click() + useval = True + Me.Hide End Sub - -Private Sub cbShip_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - Select Case KeyCode - Case 13 - useval = True - Me.Hide - Case 27 - useval = False - Me.Hide - End Select -End Sub - -Private Sub UserForm_Activate() +Public Sub Initialize(part As String, billTo As String, shipTo As String) + cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value + cbPart.value = part + cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value + cbBill.value = billTo + cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value + cbShip.value = shipTo useval = False - - cbPart.value = part - cbBill.value = bill - cbShip.value = ship - - cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value - cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value - cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value End Sub - - - diff --git a/VBA/build.frx b/VBA/build.frx index 8825394..3276752 100644 Binary files a/VBA/build.frx and b/VBA/build.frx differ diff --git a/VBA/changes.frm b/VBA/changes.frm index a8504fe..7e26192 100644 --- a/VBA/changes.frm +++ b/VBA/changes.frm @@ -1,7 +1,7 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes Caption = "History" - ClientHeight = 7785 + ClientHeight = 7815 ClientLeft = 120 ClientTop = 465 ClientWidth = 16710 @@ -13,93 +13,54 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False -Private x As Variant +Private X As Variant Private Sub cbCancel_Click() - Me.Hide - End Sub Private Sub cbUndo_Click() - - Call Me.delete_selected - End Sub Private Sub lbHist_Change() - Dim i As Integer For i = 0 To Me.lbHist.ListCount - 1 If Me.lbHist.Selected(i) Then - Me.tbPrint.value = x(i, 7) + Me.tbPrint.value = X(i, 7) Exit Sub End If Next i - End Sub - - -Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - - Select Case KeyCode - Case 46 - Call Me.delete_selected - Case 27 - Call Me.Hide - End Select - -End Sub - - - Private Sub UserForm_Activate() - Dim fail As Boolean - 'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail) - x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) + X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail) If fail Then Me.Hide Exit Sub End If - Me.lbHist.list = x + Me.lbHist.list = X - lbHEAD.ColumnCount = lbHist.ColumnCount - lbHEAD.ColumnWidths = lbHist.ColumnWidths + 'lbHEAD.ColumnCount = lbHist.ColumnCount + 'lbHEAD.ColumnWidths = lbHist.ColumnWidths ' add header elements - lbHEAD.clear - lbHEAD.AddItem - lbHEAD.list(0, 0) = "Modifier" - lbHEAD.list(0, 1) = "Owner" - lbHEAD.list(0, 2) = "When" - lbHEAD.list(0, 3) = "Tag" - lbHEAD.list(0, 4) = "Comment" - lbHEAD.list(0, 5) = "Sales" - lbHEAD.list(0, 6) = "id" +' lbHEAD.clear +' lbHEAD.AddItem +' lbHEAD.list(0, 0) = "Modifier" +' lbHEAD.list(0, 1) = "Owner" +' lbHEAD.list(0, 2) = "When" +' lbHEAD.list(0, 3) = "Tag" +' lbHEAD.list(0, 4) = "Comment" +' lbHEAD.list(0, 5) = "Sales" +' lbHEAD.list(0, 6) = "id" Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id") - - - ' make it pretty - 'body.ZOrder (1) - 'lbHEAD.ZOrder (0) - 'lbHEAD.SpecialEffect = fmSpecialEffectFlat - 'lbHEAD.BackColor = RGB(200, 200, 200) - 'lbHEAD.Height = 10 - - ' align header to body (should be done last!) - 'lbHEAD.width = lbHist.width - 'lbHEAD.Left = lbHist.Left - 'lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1) - End Sub Sub delete_selected() - Dim logid As Integer Dim i As Integer Dim fail As Boolean @@ -109,10 +70,9 @@ Sub delete_selected() Exit Sub End If - For i = 0 To Me.lbHist.ListCount - 1 If Me.lbHist.Selected(i) Then - Call handler.undo_changes(x(i, 6), fail) + Call handler.undo_changes(X(i, 6), fail) If fail Then MsgBox ("undo did not work") Exit Sub @@ -124,5 +84,4 @@ Sub delete_selected() Me.lbHist.clear Me.Hide - End Sub diff --git a/VBA/changes.frx b/VBA/changes.frx index e40b5a7..9260c15 100644 Binary files a/VBA/changes.frx and b/VBA/changes.frx differ diff --git a/VBA/fpvt.frm b/VBA/fpvt.frm index c2d3f4e..e27572d 100644 --- a/VBA/fpvt.frm +++ b/VBA/fpvt.frm @@ -1,7 +1,7 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt Caption = "Forecast Adjustment" - ClientHeight = 8595.001 + ClientHeight = 8490.001 ClientLeft = 120 ClientTop = 465 ClientWidth = 8670.001 @@ -31,7 +31,6 @@ Private set_swapalt As Boolean Private return_swap As Boolean Private jswap As Object Private cswap As Object -Private cust_s() As Boolean Private bVol As Double Private bVal As Double @@ -61,31 +60,32 @@ Private fPrcm As Double Option Explicit -Private Sub cbCancel_Click() - - tbAdjVol.value = 0 - tbAdjVal.value = 0 - tbAdjPrice.value = 0 - fpvt.Hide - +'===================================================================================================== +' Developers' backdoor to enter or exit debug mode: Ctrl-RightClick on the "Selected Scenario" +' label at the top of the form. Debug Mode shows the Pending Changes tab in the form, as well +' as all hidden sheets. +Private Sub Label62_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) + If Button = 2 And Shift = 2 Then + shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode") + mp.Pages("pAPIDOC").Visible = shConfig.Range("debug_mode") + End If End Sub - +'===================================================================================================== Private Sub butAdjust_Click() - Dim fail As Boolean Dim doc As String - + If tbAPI.text = "" Then MsgBox ("No adjustments provided") Exit Sub End If - - If cbTag.text = "" Then + + If cbTAG.text = "" Then MsgBox ("no tag was selected") Exit Sub End If - + Select Case fpvt.mp.SelectedItem.Name Case "pageSWAP" doc = tbAPI.text @@ -104,79 +104,63 @@ Private Sub butAdjust_Click() 'MsgBox ("not on an adjustable tab") 'Exit Sub End Select - + Call handler.request_adjust(doc, fail) If fail Then MsgBox ("adjustment was not made due to error") Exit Sub End If - + Me.tbCOM = "" - Me.cbTag.text = "" - + Me.cbTAG.text = "" + Me.Hide - + Set adjust = Nothing - End Sub Private Sub butCancel_Click() Me.Hide End Sub - - Private Sub butMAdjust_Click() - Dim i As Integer Dim fail As Boolean - + For i = 1 To 12 If month(i, 10) <> "" Then Call handler.request_adjust(CStr(month(i, 10)), fail) End If Next i - + Me.Hide - - End Sub Private Sub butMCancel_Click() - Me.Hide - End Sub Private Sub cbGoSheet_Click() - shMonthView.Range("MonthComment").value = "" - shMonthView.Cells(19, 5).value = 0 - shMonthView.Cells(19, 11).value = 0 - - Me.Hide - shMonthView.Range("MonthTags").value = "" + shMonthView.Range("MonthTag").value = "" + shMonthView.Range("QtyPctChange").value = 0 + shMonthView.Range("PricePctChange").value = 0 shMonthView.Visible = xlSheetVisible shMonthView.Select - + Me.Hide End Sub - Private Sub cbTAG_Change() - Dim j As Object If tbAPI.text = "" Then tbAPI.text = "{}" Set j = JsonConverter.ParseJson(tbAPI.text) - j("tag") = cbTag.value + j("tag") = cbTAG.value tbAPI.text = JsonConverter.ConvertToJson(j) - End Sub - Private Sub lbMonth_Change() - If clear_lb Or load_tb Then Exit Sub - + Dim i As Long For i = 0 To 13 If lbMonth.Selected(i) Then @@ -203,24 +187,20 @@ Private Sub lbMonth_Change() Exit For End If Next i - - - End Sub Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - If KeyCode <> 13 Then Exit Sub Dim i As Long If set_swapalt Then Exit Sub Dim vtable() As Variant Dim ptable As String - + Dim rx As Object Set rx = CreateObject("vbscript.regexp") rx.Global = True rx.Pattern = " - .*" - + For i = 0 To Me.lbSWAP.ListCount - 1 If Me.lbSWAP.Selected(i) Then vSwap(swapline, 2) = rx.Replace(cbPLIST.value, "") @@ -229,35 +209,33 @@ Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift return_swap = False End If Next i - + vtable = Utils.ARRAYp_TransposeVar(vSwap) vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") vtable = Utils.ARRAYp_TransposeVar(vtable) ptable = Utils.json_from_table_zb(vtable, "rows", True, False) Set jswap("swap") = JsonConverter.ParseJson(ptable) - + jswap("scenario")("version") = handler.plan jswap("scenario")("iter") = handler.basis jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") jswap("user") = Application.UserName jswap("source") = "adj" jswap("message") = tbCOM.text - jswap("tag") = cbTag.text + jswap("tag") = cbTAG.text jswap("type") = "swap" - + tbAPI.text = JsonConverter.ConvertToJson(jswap) - End Sub Private Sub dbGETSWAP_Click() - Dim doc As String Dim j As Object Dim fail As Boolean Dim l() As Variant Dim ptable As String Dim vtable() As Variant - + Set j = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}") 'Set j = JsonConverter.ParseJson(doc) j("new_mold") = pickSWAP.text @@ -265,9 +243,9 @@ Private Sub dbGETSWAP_Click() vSwap = handler.get_swap_fit(doc, fail) lbSWAP.list = vSwap 'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit") - + cbPLIST.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value - + '---------build change------------- Set jswap = j vtable = Utils.ARRAYp_TransposeVar(vSwap) @@ -275,24 +253,20 @@ Private Sub dbGETSWAP_Click() vtable = Utils.ARRAYp_TransposeVar(vtable) ptable = Utils.json_from_table_zb(vtable, "rows", True, False) Set jswap("swap") = JsonConverter.ParseJson(ptable) - + jswap("scenario")("version") = handler.plan jswap("scenario")("iter") = handler.basis jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss") jswap("user") = Application.UserName jswap("source") = "adj" jswap("message") = tbCOM.text - jswap("tag") = cbTag.text + jswap("tag") = cbTAG.text jswap("type") = "swap" - + tbAPI.text = JsonConverter.ConvertToJson(jswap) - - End Sub - Private Sub lbSWAP_Change() - Dim i As Long If return_swap Then Exit Sub @@ -304,192 +278,103 @@ Private Sub lbSWAP_Change() swapline = i End If Next i - End Sub -Private Sub lbSWAP_DblClick(ByVal Cancel As MSForms.ReturnBoolean) - -' Dim rx As Object -' Set rx = CreateObject("vbscript.regexp") -' rx.Global = True -' rx.Pattern = " - .*" -' Dim match As Object -' Dim i As Long -' Dim v As Variant -' -' 'v = Me.lbSWAP.list -' -' For i = 0 To Me.lbSWAP.ListCount - 1 -' If Me.lbSWAP.Selected(i) Then -' part.Show -' If Not part.useval Then -' Exit Sub -' End If -' 'vSwap(i, 3) = rx.Execute(part.cbPart.value) -' 'v(i, 2) = rx.Replace(part.cbPart.value, "") -' 'Me.lbSWAP.list = v -' End If -' Next i -' -End Sub - - Private Sub opEditPrice_Click() - - opPlugVol.Enabled = False - opPlugPrice.Enabled = False opPlugVol.Visible = False opPlugPrice.Visible = False opPlugPrice.value = True opPlugVol.value = False - + tbFcPrice.Enabled = True tbFcPrice.BackColor = &H80000018 tbFcVal.Enabled = False tbFcVal.BackColor = &H80000005 tbFcVol.Enabled = True tbFcVol.BackColor = &H80000018 - + sbpv.Enabled = True sbpp.Enabled = True sbpd.Enabled = False tbpv.Enabled = True tbpp.Enabled = True tbpd.Enabled = False - End Sub Private Sub opEditSales_Click() - - opPlugVol.Enabled = True - opPlugPrice.Enabled = True opPlugVol.Visible = True opPlugPrice.Visible = True - + tbFcPrice.Enabled = False tbFcPrice.BackColor = &H80000005 tbFcVal.Enabled = True tbFcVal.BackColor = &H80000018 tbFcVol.Enabled = False tbFcVol.BackColor = &H80000005 - + sbpv.Enabled = False sbpp.Enabled = False sbpd.Enabled = True tbpv.Enabled = False tbpp.Enabled = False tbpd.Enabled = True - End Sub - Private Sub opEditPriceM_Click() - opmvol.Enabled = False opmprice.Enabled = False opmvol.Visible = False opmprice.Visible = False opmprice.value = True opmvol.value = True - + tbMFPrice.Enabled = True tbMFPrice.BackColor = &H80000018 tbMFVal.Enabled = False tbMFVal.BackColor = &H80000005 tbMFVol.Enabled = True tbMFVol.BackColor = &H80000018 - End Sub Private Sub opEditSalesM_Click() - opmvol.Enabled = True opmprice.Enabled = True opmvol.Visible = True opmprice.Visible = True - + tbMFPrice.Enabled = False tbMFPrice.BackColor = &H80000005 tbMFVal.Enabled = True tbMFVal.BackColor = &H80000018 tbMFVol.Enabled = False tbMFVol.BackColor = &H80000005 - -End Sub - -Private Sub opEditVolM_Click() - - opmvol.Enabled = False - opmprice.Enabled = False - opmprice.value = False - opmvol.value = True - opmvol.Enabled = False - opmprice.Enabled = False - opmvol.Visible = False - opmprice.Visible = False - - tbMFPrice.Enabled = False - tbMFPrice.BackColor = &H80000005 - tbMFVal.Enabled = False - tbMFVal.BackColor = &H80000005 - tbMFVol.Enabled = True - tbMFVol.BackColor = &H80000018 End Sub Private Sub opPlugPrice_Click() calc_val - If opPlugPrice.value = True Then - opPlugPrice.BackColor = -2147483624 - Else - opPlugPrice.BackColor = -2147483644 - End If - If opPlugVol.value = True Then - opPlugVol.BackColor = -2147483624 - Else - opPlugVol.BackColor = -2147483644 - End If - End Sub Private Sub opPlugVol_Click() calc_val - If opPlugVol.value = True Then - opPlugVol.BackColor = -2147483624 - Else - opPlugVol.BackColor = -2147483644 - End If - If opPlugPrice.value = True Then - opPlugPrice.BackColor = -2147483624 - Else - opPlugPrice.BackColor = -2147483644 - End If End Sub Private Sub sbpd_Change() - tbpd.value = sbpd.value - End Sub Private Sub sbpp_Change() - tbpp.value = sbpp.value - End Sub Private Sub sbpv_Change() - tbpv.value = sbpv.value - End Sub Private Sub tbCOM_Change() - If tbAPI.text = "" Then tbAPI.text = "{}" Set adjust = JsonConverter.ParseJson(tbAPI.text) adjust("message") = tbCOM.text tbAPI.text = JsonConverter.ConvertToJson(adjust) - End Sub Private Sub tbFcPrice_Change() @@ -500,10 +385,8 @@ Private Sub tbFcPrice_Change() End Sub Private Sub tbFcVal_Change() - If load_tb Then Exit Sub If opEditSales Then calc_val - End Sub Private Sub tbFcVol_Change() @@ -522,89 +405,71 @@ Private Sub opmVol_Click() End Sub Private Sub tbmfPrice_Change() - If mline = 0 Then Exit Sub If clear_lb Or load_tb Then Exit Sub set_Price = True If opEditPriceM Then calc_mprice set_Price = False - End Sub - - Private Sub tbMFVal_Change() - If mline = 0 Then Exit Sub If clear_lb Or load_tb Then Exit Sub If opEditSalesM Then calc_mval - End Sub Private Sub tbmfVol_Change() - If mline = 0 Then Exit Sub If clear_lb Or load_tb Then Exit Sub If opEditPriceM Then calc_mprice - End Sub Private Sub tbpd_Change() - If load_tb Then Exit Sub If Not VBA.IsNumeric(tbpd.value) Then tbpd = "0" End If tbFcVal = (bVal + pVal) * (1 + tbpd.value / 100) - End Sub Private Sub tbpp_Change() - If load_tb Then Exit Sub If Not VBA.IsNumeric(tbpd.value) Then tbpd = "0" End If tbFcPrice = (bPrc + pPrc) * (1 + tbpp.value / 100) Me.load_mbox_ann - End Sub Private Sub tbpv_Change() - If load_tb Then Exit Sub If Not VBA.IsNumeric(tbpv.value) Then tbpd = "0" End If tbFcVol = (bVol + pVol) * (1 + tbpv.value / 100) - - End Sub Private Sub UserForm_Activate() - Dim i As Long Dim j As Long Dim k As Long Dim ok As Boolean -' Dim tags() As Variant - + Me.Caption = "Forecast Adjust " & shConfig.Range("version").value & " Loading..." Me.mp.Visible = False Me.fraExit.Visible = False - + Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") - + Me.Caption = "Forecast Adjust " & shConfig.Range("version").value - + If Not ok Then fpvt.Hide Application.StatusBar = False Exit Sub End If - - + '---show existing adjustment if there is one---- fpvt.mod_adjust = False pVol = 0 @@ -620,13 +485,13 @@ Private Sub UserForm_Activate() fVol = 0 fPrc = 0 Me.tbAPI.value = "" - + If IsNull(sp("package")("totals")) Then fpvt.Hide Application.StatusBar = False Exit Sub End If - + For i = 1 To sp("package")("totals").Count Select Case sp("package")("totals")(i)("order_season") Case 2024 @@ -635,17 +500,17 @@ Private Sub UserForm_Activate() bVol = bVol + sp("package")("totals")(i)("units") bVal = bVal + sp("package")("totals")(i)("value_usd") If bVol <> 0 Then bPrc = bVal / bVol - + Case "adjust" pVol = pVol + sp("package")("totals")(i)("units") pVal = pVal + sp("package")("totals")(i)("value_usd") - + Case "exclude" End Select End Select Next i - + fVol = bVol + pVol fVal = bVal + pVal If fVol = 0 Then @@ -666,13 +531,13 @@ Private Sub UserForm_Activate() MsgBox (aVal) End If Me.load_mbox_ann - + '---------------------------------------populate monthly------------------------------------------------------- - + k = 0 '--parse json into variant array for loading-- ReDim month(sp("package")("mpvt").Count + 1, 10) - + For i = 1 To sp("package")("mpvt").Count month(i, 0) = sp("package")("mpvt")(i)("order_month") month(i, 1) = sp("package")("mpvt")(i)("2023 qty") @@ -689,7 +554,7 @@ Private Sub UserForm_Activate() month(i, 9) = "scale" End If Next i - + month(0, 0) = "month" month(13, 0) = "total" month(0, 1) = "2023 qty" @@ -700,11 +565,11 @@ Private Sub UserForm_Activate() month(0, 6) = "2024 base val" month(0, 7) = "2024 adj val" month(0, 8) = "2024 val" - + Me.crunch_array - + ReDim basket(sp("package")("basket").Count, 3) - + ' basket(0, 0) = "order_season" ' basket(0, 1) = "order_month" ' basket(0, 2) = "version" @@ -718,8 +583,7 @@ Private Sub UserForm_Activate() basket(0, 1) = "bill_cust_descr" basket(0, 2) = "ship_cust_descr" basket(0, 3) = "mix" - - + For i = 1 To UBound(basket, 1) 'basket(i, 0) = sp("package")("base")(i)("order_season") 'basket(i, 1) = sp("package")("base")(i)("order_month") @@ -735,30 +599,28 @@ Private Sub UserForm_Activate() basket(i, 2) = sp("package")("basket")(i)("ship_cust_descr") basket(i, 3) = sp("package")("basket")(i)("mix") Next i - + '---------------get list of customers---------------------------- - + ReDim cust(sp("package")("customers").Count - 1, 3) - - + For i = 0 To UBound(cust, 1) cust(i, 0) = sp("package")("customers")(i + 1)("bill_cust_descr") cust(i, 1) = "" cust(i, 2) = sp("package")("customers")(i + 1)("ship_cust_descr") cust(i, 3) = "" Next i - + Call Utils.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace") - - + '-------------load tags------------------------------- - cbTag.list = shConfig.ListObjects("TAGS").DataBodyRange.value - + cbTAG.list = shConfig.ListObjects("TAGS").DataBodyRange.value + '----------reset spinner buttons---------------------- sbpv.value = 0 sbpp.value = 0 sbpd.value = 0 - + '--------reset swap tab------------------------------- lbSWAP.clear pickSWAP.value = "" @@ -768,32 +630,18 @@ Private Sub UserForm_Activate() cbST.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value lbCUST.list = cust Call Utils.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit") - - '---------price volume radio button colors---------- - If opPlugPrice.value = True Then - opPlugPrice.BackColor = -2147483624 - Else - opPlugPrice.BackColor = -2147483644 - End If - If opPlugVol.value = True Then - opPlugVol.BackColor = -2147483624 - Else - opPlugVol.BackColor = -2147483644 - End If - - 'Application.Calculation = xlCalculationManual + Call handler.month_tosheet(month, basket) Application.StatusBar = False - + Me.mp.Visible = True Me.fraExit.Visible = True - End Sub Sub crunch_array() Dim i As Integer - + month(13, 1) = 0 month(13, 2) = 0 month(13, 3) = 0 @@ -802,7 +650,7 @@ Sub crunch_array() month(13, 6) = 0 month(13, 7) = 0 month(13, 8) = 0 - + For i = 1 To 12 month(13, 1) = month(13, 1) + co_num(month(i, 1), 0) month(13, 2) = month(13, 2) + co_num(month(i, 2), 0) @@ -813,7 +661,7 @@ Sub crunch_array() month(13, 7) = month(13, 7) + co_num(month(i, 7), 0) month(13, 8) = month(13, 8) + co_num(month(i, 8), 0) Next i - + ReDim mload(UBound(month, 1), 5) For i = 0 To UBound(month, 1) mload(i, 0) = month(i, 0) @@ -822,66 +670,56 @@ Sub crunch_array() mload(i, 3) = Format(month(i, 5), "#,###") mload(i, 4) = Format(month(i, 8), "#,###") Next i - + 'mline = 0 clear_lb = True lbMonth.clear lbMonth.list = mload clear_lb = False - End Sub Private Sub lbCUST_Change() - Dim i As Long - Dim x() As Variant - - x = lbCUST.list - For i = 0 To UBound(x, 1) + Dim X() As Variant + + X = lbCUST.list + For i = 0 To UBound(X, 1) If lbCUST.Selected(i) Then Exit For Next i - cbBT.text = x(i, 0) - cbST.text = x(i, 2) - - + cbBT.text = X(i, 0) + cbST.text = X(i, 2) End Sub - Private Sub cbBT_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - If KeyCode <> 13 Then Exit Sub - + Dim i As Long - Dim x() As Variant - - x = lbCUST.list - For i = 0 To UBound(x, 1) - If lbCUST.Selected(i) Then x(i, 1) = Me.rev_cust(cbBT.text) + Dim X() As Variant + + X = lbCUST.list + For i = 0 To UBound(X, 1) + If lbCUST.Selected(i) Then X(i, 1) = Me.rev_cust(cbBT.text) Next i - lbCUST.list = x + lbCUST.list = X Call Me.build_cust_swap - End Sub Private Sub cbST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - If KeyCode <> 13 Then Exit Sub - + Dim i As Long - Dim x() As Variant - - x = lbCUST.list - For i = 0 To UBound(x, 1) - If lbCUST.Selected(i) Then x(i, 3) = Me.rev_cust(cbST.text) + Dim X() As Variant + + X = lbCUST.list + For i = 0 To UBound(X, 1) + If lbCUST.Selected(i) Then X(i, 3) = Me.rev_cust(cbST.text) Next i - lbCUST.list = x + lbCUST.list = X Call Me.build_cust_swap - - End Sub Sub build_cust_swap() - + Dim vtable() As Variant Dim ptable As String vtable = lbCUST.list @@ -896,22 +734,19 @@ Sub build_cust_swap() cswap("user") = Application.UserName cswap("source") = "adj" cswap("message") = tbCOM.text - cswap("tag") = cbTag.text + cswap("tag") = cbTAG.text cswap("type") = "cust_swap" Set cswap("swap") = JsonConverter.ParseJson(ptable) - - tbAPI.text = JsonConverter.ConvertToJson(cswap) - + tbAPI.text = JsonConverter.ConvertToJson(cswap) End Sub Public Function rev_cust(cust As String) As String - If cust = "" Then rev_cust = "" Exit Function End If - + If InStr(1, cust, " - ") <= 9 Then rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8)) Else @@ -925,25 +760,24 @@ Sub load_var() 'base bVolm = co_num(month(mline, 2), 0) bValm = co_num(month(mline, 6), 0) - + 'prior adjust pVolm = co_num(month(mline, 3), 0) pValm = co_num(month(mline, 7), 0) - + 'current forecast fVolm = co_num(month(mline, 4), 0) fValm = co_num(month(mline, 8), 0) - + 'adjustment aVolm = fVolm - (bVolm + pVolm) aValm = fValm - (bValm + pValm) - If month(mline, 9) = "addmonth" Then nomonth = True bPrcm = month(13, 6) / month(13, 2) fPrcm = month(13, 8) / month(13, 4) - + Else 'prices If bVolm <> 0 Then bPrcm = bValm / bVolm @@ -951,7 +785,6 @@ Sub load_var() If fVolm <> 0 Then fPrcm = fValm / fVolm aPrcm = fPrcm - (bPrcm + pPrcm) End If - End Sub Sub load_mbox() @@ -961,21 +794,20 @@ Sub load_mbox() tbMBaseVol = Format(bVolm, "#,###") tbMBaseVal = Format(bValm, "#,###") tbMBasePrice = Format(bPrcm, "0.00000") - + tbMPAVol = Format(pVolm, "#,###") tbmPAVal = Format(pValm, "#,###") tbMPAPrice = Format(pPrcm, "0.00000") - + tbMFVol = Format(fVolm, "#,###") tbMFVal = Format(fValm, "#,###") If Not set_Price Then tbMFPrice = Format(fPrcm, "0.#####") - + tbMAVol = Format(aVolm, "#,###") tbMAVal = Format(aValm, "#,###") tbMAPrice = Format(aPrcm, "0.00000") - - load_tb = False + load_tb = False End Sub Sub load_mbox_ann() @@ -985,21 +817,20 @@ Sub load_mbox_ann() tbBaseVol = Format(bVol, "#,##0") tbBaseVal = Format(bVal, "#,##0") tbBasePrice = Format(bPrc, "0.00000") - + tbPadjVol = Format(pVol, "#,##0") tbPadjVal = Format(pVal, "#,##0") tbPadjPrice = Format(pPrc, "0.00000") - + tbFcVol = Format(fVol, "#,##0") tbFcVal = Format(fVal, "#,##0") If Not set_Price Then tbFcPrice = Format(fPrc, "0.00000") - + tbAdjVol = Format(aVol, "#,##0") tbAdjVal = Format(aVal, "#,##0") tbAdjPrice = Format(aPrc, "0.00000") - - load_tb = False + load_tb = False End Sub Sub load_array() @@ -1007,20 +838,18 @@ Sub load_array() 'base month(mline, 2) = bVolm month(mline, 6) = bValm - + 'prior adjust month(mline, 3) = pVolm month(mline, 7) = pValm - + 'current forecast month(mline, 4) = fVolm month(mline, 8) = fValm - + Me.crunch_array - End Sub - Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant If Not IsNumeric(one) Or IsNull(one) Then @@ -1040,7 +869,7 @@ Sub calc_val() fVal = tbFcVal.value 'do calculations aVal = fVal - bVal - pVal - + '---------if volume adjustment method is selected, scale the volume up---------------------------------- If opPlugVol Then If (Round(pVal, 2) + Round(bVal, 2)) = 0 Then @@ -1054,7 +883,7 @@ Sub calc_val() pchange = fVal / (pVal + bVal) fVol = (pVol + bVol) * pchange End If - + Else fVol = pVol + bVol End If @@ -1068,12 +897,12 @@ Sub calc_val() Else aVol = fVol - bVol - pVol aPrc = 0 - + End If tbFcVal = Format(co_num(tbFcVal, 0), "#,##0") - + Me.load_mbox_ann - + 'build json Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") adjust("scenario")("version") = handler.plan @@ -1082,7 +911,7 @@ Sub calc_val() adjust("user") = Application.UserName adjust("source") = "adj" adjust("message") = tbCOM.text - adjust("tag") = cbTag.text + adjust("tag") = cbTAG.text If opEditSales Then If opPlugVol Then adjust("type") = "scale_v" @@ -1097,20 +926,19 @@ Sub calc_val() adjust("qty") = aVol adjust("amount") = aVal End If - + 'print json tbAPI = JsonConverter.ConvertToJson(adjust) - End Sub Sub calc_price() - + 'If IsNumeric(tbFcPrice.value) And tbFcPrice.value <> 0 And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then 'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then - + 'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) Then 'capture currently changed item - + fVol = co_num(tbFcVol.value, 0) fPrc = co_num(tbFcPrice.value, 0) 'calc @@ -1125,9 +953,9 @@ Sub calc_price() aPrc = fPrc - (bPrc + pPrc) End If 'End If - + Me.load_mbox_ann - + 'build json Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") adjust("scenario")("version") = handler.plan @@ -1136,9 +964,9 @@ Sub calc_price() adjust("user") = Application.UserName adjust("source") = "adj" adjust("message") = tbCOM.text - adjust("tag") = cbTag.text + adjust("tag") = cbTAG.text adjust("version") = handler.plan - + If opEditSales Then If opPlugVol Then adjust("type") = "scale_v" @@ -1159,21 +987,19 @@ Sub calc_price() 'print json tbAPI = JsonConverter.ConvertToJson(adjust) - End Sub - Sub calc_mval() Dim pchange As Double Dim j As Object - + If IsNumeric(tbMFVal.value) Then 'get textbox value fValm = tbMFVal.value 'do calculations aValm = fValm - bValm - pValm - + '---------if volume adjustment method is selected, scale the volume up---------------------------------- If nomonth Then fVolm = fValm / bPrcm @@ -1198,9 +1024,9 @@ Sub calc_mval() aPrcm = 0 End If tbMFVal = Format(tbMFVal, "#,###") - + 'build json - + Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") j("scenario")("version") = handler.plan j("scenario")("iter") = handler.basis @@ -1238,13 +1064,12 @@ Sub calc_mval() j("qty") = aVolm j("amount") = aValm End If - + month(mline, 10) = JsonConverter.ConvertToJson(j) tbAPI = JsonConverter.ConvertToJson(j) - + Me.load_mbox Me.load_array - End Sub Sub calc_mprice() @@ -1268,7 +1093,7 @@ Sub calc_mprice() fValm = 0 aValm = fValm - bValm - pValm End If - + 'build json Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") j("scenario")("version") = handler.plan @@ -1312,19 +1137,17 @@ Sub calc_mprice() j("qty") = aVolm j("amount") = aValm End If - + month(mline, 10) = JsonConverter.ConvertToJson(j) tbAPI = JsonConverter.ConvertToJson(j) - - + If clear_lb Then MsgBox ("clear") Me.load_mbox Me.load_array - End Sub Function iter_def(ByVal iter As String) As String - + Dim i As Integer For i = 0 To UBound(handler.baseline) @@ -1333,14 +1156,16 @@ Function iter_def(ByVal iter As String) As String Exit Function End If Next i - + For i = 0 To UBound(handler.adjust) If handler.adjust(i) = iter Then iter_def = "adjust" Exit Function End If Next i - + iter_def = "exclude" End Function + + diff --git a/VBA/fpvt.frx b/VBA/fpvt.frx index 79cfcf4..4b8bc34 100644 Binary files a/VBA/fpvt.frx and b/VBA/fpvt.frx differ diff --git a/VBA/handler.bas b/VBA/handler.bas index 34d6160..017ef44 100644 --- a/VBA/handler.bas +++ b/VBA/handler.bas @@ -104,7 +104,7 @@ Sub pg_main_workset(rep As String) Exit Sub End If - ReDim res(json("x").Count, 33) + ReDim res(json("x").Count, 34) For i = 1 To UBound(res, 1) res(i, 0) = json("x")(i)("bill_cust_descr") @@ -141,6 +141,7 @@ Sub pg_main_workset(rep As String) res(i, 31) = json("x")(i)("logid") res(i, 32) = json("x")(i)("tag") res(i, 33) = json("x")(i)("comment") + res(i, 34) = json("x")(i)("pounds") Next i res(0, 0) = "bill_cust_descr" @@ -177,6 +178,7 @@ Sub pg_main_workset(rep As String) res(0, 31) = "logid" res(0, 32) = "tag" res(0, 33) = "comment" + res(0, 34) = "pounds" Set json = Nothing @@ -456,7 +458,7 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant) shConfig.Range("show_basket").value = 0 shConfig.Range("new_part").value = 0 - shMonthView.load_sheet + shMonthView.LoadSheet End With diff --git a/VBA/openf.frm b/VBA/openf.frm index fab3836..06b398c 100644 --- a/VBA/openf.frm +++ b/VBA/openf.frm @@ -1,10 +1,10 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf Caption = "Open a Forecast" - ClientHeight = 2025 + ClientHeight = 1365 ClientLeft = 120 ClientTop = 465 - ClientWidth = 3825 + ClientWidth = 6825 OleObjectBlob = "openf.frx":0000 StartUpPosition = 1 'CenterOwner End @@ -33,10 +33,7 @@ End Sub Private Sub UserForm_Activate() - 'handler.server = "http://192.168.1.69:3000" handler.server = shConfig.Range("server").value - - openf.Caption = "Select a DSM" cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value End Sub diff --git a/VBA/openf.frx b/VBA/openf.frx index e4c3eed..d14a180 100644 Binary files a/VBA/openf.frx and b/VBA/openf.frx differ diff --git a/VBA/part.frm b/VBA/part.frm index 50960e0..7c23040 100644 --- a/VBA/part.frm +++ b/VBA/part.frm @@ -1,10 +1,10 @@ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part Caption = "Part Picker" - ClientHeight = 1080 + ClientHeight = 1335 ClientLeft = 120 ClientTop = 465 - ClientWidth = 8100 + ClientWidth = 9285.001 OleObjectBlob = "part.frx":0000 StartUpPosition = 1 'CenterOwner End @@ -13,34 +13,23 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False - -Public part As String -Public bill As String -Public ship As String -Public useval As Boolean Option Explicit +Public useval As Boolean -Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) - - Select Case KeyCode - Case 13 - useval = True - Me.Hide - Case 27 - useval = False - Me.Hide - End Select - +Private Sub cmdCancel_Click() + useval = False + Me.Hide End Sub - +Private Sub cmdOK_Click() + useval = True + Me.Hide +End Sub Private Sub UserForm_Activate() - useval = False cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value - End Sub diff --git a/VBA/part.frx b/VBA/part.frx index ec970e4..f223fbe 100644 Binary files a/VBA/part.frx and b/VBA/part.frx differ diff --git a/VBA/shConfig.cls b/VBA/shConfig.cls index f5f7841..9fc9c32 100644 --- a/VBA/shConfig.cls +++ b/VBA/shConfig.cls @@ -7,3 +7,23 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True +Option Explicit + +Private Sub Worksheet_Change(ByVal Target As Range) + If shConfig.Range("debug_mode").value Then + shConfig.Visible = xlSheetVisible + shData.Visible = xlSheetVisible + shMonthView.Visible = xlSheetVisible + shMonthUpdate.Visible = xlSheetVisible + shSupportingData.Visible = xlSheetVisible + shWalk.Visible = xlSheetVisible + Else + shConfig.Visible = xlSheetVeryHidden + shData.Visible = xlSheetHidden + shMonthView.Visible = xlSheetHidden + shMonthUpdate.Visible = xlSheetVeryHidden + shSupportingData.Visible = xlSheetVeryHidden + shWalk.Visible = xlSheetVeryHidden + End If +End Sub + diff --git a/VBA/shHelp.cls b/VBA/shHelp.cls new file mode 100644 index 0000000..940e153 --- /dev/null +++ b/VBA/shHelp.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "shHelp" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/VBA/shMonthView.cls b/VBA/shMonthView.cls index cb6be1a..8c347d1 100644 --- a/VBA/shMonthView.cls +++ b/VBA/shMonthView.cls @@ -15,22 +15,20 @@ Private sales() As Variant Private tunits() As Variant Private tprice() As Variant Private tsales() As Variant -Private dumping As Boolean +Private busy As Boolean Private vedit As String Private adjust() As Object Private jtext() As Variant Private rollback As Boolean Private scenario() As Variant Private orig As Range -Private basket_touch As Range Private showbasket As Boolean Private np As Object 'json dedicated to new part scenario -Private b() As Variant 'holds basket Private did_load_config As Boolean Public Sub MPP_Down() ' Handler for down-triangle on price percent change. If newpart Then Exit Sub - + With shMonthView.Range("PricePctChange") .value = WorksheetFunction.Max(-0.1, .value - 0.01) End With @@ -39,7 +37,7 @@ End Sub Public Sub MPP_Up() ' Handler for up-triangle on price percent change. If newpart Then Exit Sub - + With shMonthView.Range("PricePctChange") .value = WorksheetFunction.Min(0.1, .value + 0.01) End With @@ -48,11 +46,11 @@ End Sub Private Sub MPP_Change() Dim i As Long - + Application.ScreenUpdating = False - - dumping = True - + + busy = True + With shMonthView For i = 1 To 12 If .Range("PriceBaseline").Cells(i) > 0 Then @@ -61,16 +59,16 @@ Private Sub MPP_Change() Next i End With Me.mvp_adj - - dumping = False - + + busy = False + Application.ScreenUpdating = True End Sub Public Sub MPV_Down() ' Handler for down-triangle on qty percent change. If newpart Then Exit Sub - + With shMonthView.Range("QtyPctChange") .value = WorksheetFunction.Max(-0.1, .value - 0.01) End With @@ -79,7 +77,7 @@ End Sub Public Sub MPV_Up() ' Handler for up-triangle on qty percent change. If newpart Then Exit Sub - + With shMonthView.Range("QtyPctChange") .value = WorksheetFunction.Min(0.1, .value + 0.01) End With @@ -88,11 +86,11 @@ End Sub Private Sub MPV_Change() Dim i As Long - + Application.ScreenUpdating = False - - dumping = True - + + busy = True + With shMonthView For i = 1 To 12 If .Range("QtyBaseline").Cells(i) <> 0 Then @@ -100,50 +98,54 @@ Private Sub MPV_Change() End If Next i End With - - dumping = False - + + busy = False + Call Me.mvp_adj - + Application.ScreenUpdating = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) - '---this needs checked prior to dumping check because % increase spinners are flagged as dumps + '---this needs checked prior to busy check because % increase spinners are flagged as dumps If Not did_load_config Then Call handler.load_config did_load_config = True End If - If dumping Then Exit Sub - - If Not Intersect(Target, Range("A1:R18")) Is Nothing Then - If Target.Columns.Count > 1 Then - MsgBox ("you can only change one column at a time - your change will be undone") - dumping = True - Application.Undo - dumping = False - Exit Sub - End If + If busy Then Exit Sub + + If (IntersectsWith(Target, Range("units")) Or _ + IntersectsWith(Target, Range("price")) Or _ + IntersectsWith(Target, Range("sales"))) And _ + Target.Columns.Count > 1 _ + Then + MsgBox ("you can only change one column at a time - your change will be undone") + busy = True + Application.Undo + busy = False + Exit Sub End If - - If Not Intersect(Target, Range("QtyNewAdj")) Is Nothing Then Call Me.mvp_adj - If Not Intersect(Target, Range("QtyFinal")) Is Nothing Then Call Me.mvp_set - If Not Intersect(Target, Range("PriceNewAdj")) Is Nothing Then Call Me.mvp_adj - If Not Intersect(Target, Range("PriceFinal")) Is Nothing Then Call Me.mvp_set - If Not Intersect(Target, Range("SalesNewAdj")) Is Nothing Then Call Me.ms_adj - If Not Intersect(Target, Range("SalesFinal")) Is Nothing Then Call Me.ms_set - - If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then - Set basket_touch = Target - Call Me.get_edit_basket - Set basket_touch = Nothing + + If IntersectsWith(Target, Range("QtyNewAdj")) Then Call Me.mvp_adj + If IntersectsWith(Target, Range("QtyFinal")) Then Call Me.mvp_set + If IntersectsWith(Target, Range("PriceNewAdj")) Then Call Me.mvp_adj + If IntersectsWith(Target, Range("PriceFinal")) Then Call Me.mvp_set + If IntersectsWith(Target, Range("SalesNewAdj")) Then Call Me.ms_adj + If IntersectsWith(Target, Range("SalesFinal")) Then Call Me.ms_set + + If IntersectsWith(Target, Range("basket")) And shConfig.Range("show_basket").value = 1 Then + If RemoveEmptyBasketLines Then ' Lines were removed + GetEditBasket shMonthView.Range("basket").Resize(1, 1) ' Don't "touch" the mix column, so as to rescale all rows proportionally to 100% total. + Else + GetEditBasket Target + End If End If End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) - If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then + If IntersectsWith(Target, Union(Range("basket_new_item"), Range("basket"))) And shConfig.Range("show_basket").value = 1 Then Cancel = True Call Me.basket_pick(Target) Target.Select @@ -152,29 +154,19 @@ End Sub Sub picker_shortcut() - If Not Intersect(Selection, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then + If IntersectsWith(Selection, Range("basket")) And shConfig.Range("show_basket").value = 1 Then Call Me.basket_pick(Selection) End If End Sub -Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) - - If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then - Cancel = True - Call Me.basket_pick(Target) - Target.Select - End If - -End Sub - Public Function rev_cust(cust As String) As String If cust = "" Then rev_cust = "" Exit Function End If - + If InStr(1, cust, " - ") <= 9 Then rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8)) Else @@ -186,7 +178,7 @@ End Function Sub mvp_set() Dim i As Integer - Call Me.get_sheet + GetSheet For i = 1 To 12 If units(i, 5) = "" Then units(i, 5) = 0 @@ -200,18 +192,18 @@ Sub mvp_set() sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) End If Next i - - Me.crunch_array - Me.build_json - Me.set_sheet - - + + CrunchArray + BuildJson + SetSheet + + End Sub Sub mvp_adj() Dim i As Integer - Call Me.get_sheet + GetSheet For i = 1 To 12 If units(i, 4) = "" Then units(i, 4) = 0 @@ -225,12 +217,12 @@ Sub mvp_adj() sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) End If Next i - - Me.crunch_array - Me.build_json - Me.set_sheet - - + + CrunchArray + BuildJson + SetSheet + + End Sub Sub ms_set() @@ -238,147 +230,139 @@ Sub ms_set() On Error GoTo errh Dim i As Integer - Call Me.get_sheet - Dim vp As String - vp = shMonthView.Range("MonthVariable") + GetSheet For i = 1 To 12 If sales(i, 5) = "" Then sales(i, 5) = 0 If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 2) <> Round(sales(i, 4), 2) Then sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) - Select Case vp - Case "volume" - If co_num(price(i, 5), 0) = 0 Then - MsgBox ("price cannot be -0- and also have sales - your change will be undone") - dumping = True - Application.Undo - dumping = False - Exit Sub - End If - 'reset price to original - delete these lines if a cascading effect is desired - 'price(i, 4) = 0 - 'price(i, 5) = price(i, 2) + price(i, 3) - 'calc volume change on original price - units(i, 5) = sales(i, 5) / price(i, 5) - units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) - Case "price" - If co_num(units(i, 5), 0) = 0 Then - MsgBox ("volume cannot be -0- and also have sales - your change will be undone") - dumping = True - Application.Undo - dumping = False - Exit Sub - End If - price(i, 5) = sales(i, 5) / units(i, 5) - price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) - Case Else - MsgBox ("error forcing sales with no offset specified - your change will be undone") - dumping = True + + If shMonthView.Range("MonthAdjustVolume") Then + If co_num(price(i, 5), 0) = 0 Then + MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True Application.Undo - dumping = False + busy = False Exit Sub - End Select + End If + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + + ElseIf shMonthView.Range("MonthAdjustPrice") Then + If co_num(units(i, 5), 0) = 0 Then + MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + price(i, 5) = sales(i, 5) / units(i, 5) + price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) + + Else + MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup" + busy = True + Application.Undo + busy = False + Exit Sub + End If End If Next i - - Me.crunch_array - Me.build_json - Me.set_sheet + + CrunchArray + BuildJson + SetSheet errh: If Err.Number <> 0 Then rollback = True - - + + End Sub Sub ms_adj() Dim i As Integer - Call Me.get_sheet - Dim vp As String - vp = shMonthView.Range("MonthVariable") + GetSheet For i = 1 To 12 If sales(i, 4) = "" Then sales(i, 4) = 0 If Round(sales(i, 5), 6) <> Round(sales(i, 2) + sales(i, 3) + sales(i, 4), 6) Then sales(i, 5) = sales(i, 4) + sales(i, 2) + sales(i, 3) - Select Case vp - Case "volume" - If co_num(price(i, 5), 0) = 0 Then - MsgBox ("price cannot be -0- and also have sales - your change will be undone") - dumping = True - Application.Undo - dumping = False - Exit Sub - End If - 'reset price to original - 'price(i, 4) = 0 - 'price(i, 5) = price(i, 2) + price(i, 3) - 'calc volume change on original price - units(i, 5) = sales(i, 5) / price(i, 5) - units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) - Case "price" - If co_num(units(i, 5), 0) = 0 Then - MsgBox ("volume cannot be -0- and also have sales - your change will be undone") - dumping = True - Application.Undo - dumping = False - Exit Sub - End If - price(i, 5) = sales(i, 5) / units(i, 5) - price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) - Case Else - MsgBox ("error forcing sales with no offset specified - your change will be undone") - dumping = True + + If shMonthView.Range("MonthAdjustVolume") Then + If co_num(price(i, 5), 0) = 0 Then + MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True Application.Undo - dumping = False + busy = False Exit Sub - End Select + End If + units(i, 5) = sales(i, 5) / price(i, 5) + units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) + + ElseIf shMonthView.Range("MonthAdjustPrice") Then + If co_num(units(i, 5), 0) = 0 Then + MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero" + busy = True + Application.Undo + busy = False + Exit Sub + End If + price(i, 5) = sales(i, 5) / units(i, 5) + price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) + + Else + MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup" + busy = True + Application.Undo + busy = False + Exit Sub + End If End If Next i - - Me.crunch_array - Me.build_json - Me.set_sheet - - + + CrunchArray + BuildJson + SetSheet + End Sub -Sub get_sheet() - - Dim i As Integer - - units = Range("units") - price = Range("price") - sales = Range("sales") - tunits = Range("tunits") - tprice = Range("tprice") - tsales = Range("tsales") - ReDim adjust(12) - +Private Sub GetSheet() + With shMonthView + units = .Range("units") + price = .Range("price") + sales = .Range("sales") + tunits = .Range("tunits") + tprice = .Range("tprice") + tsales = .Range("tsales") + ReDim adjust(12) + End With End Sub Private Function basejson() As Object Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1) End Function -Sub set_sheet() +Private Sub SetSheet() Dim i As Integer - dumping = True - - Range("units") = units - Range("price") = price - Range("sales") = sales - Range("tunits").FormulaR1C1 = tunits - Range("tprice").FormulaR1C1 = tprice - Range("tsales").FormulaR1C1 = tsales - Range("scenario").ClearContents - Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False) - 'shMonthView.Range("B32:Q5000").ClearContents - + busy = True + + With shMonthView + .Range("units") = units + .Range("price") = price + .Range("sales") = sales + .Range("tunits").FormulaR1C1 = tunits + .Range("tprice").FormulaR1C1 = tprice + .Range("tsales").FormulaR1C1 = tsales + .Range("scenario").ClearContents + + Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), .Name, .Range("scenario").row, .Range("scenario").Column, False, False, False) + '.Range("B32:Q5000").ClearContents + End With + If Me.newpart Then shMonthUpdate.Range("P2:P13").ClearContents shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) @@ -387,164 +371,32 @@ Sub set_sheet() shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If - - dumping = False - + + busy = False + End Sub -Sub load_sheet() +Public Sub LoadSheet() units = shMonthUpdate.Range("A2:E13").FormulaR1C1 price = shMonthUpdate.Range("F2:J13").FormulaR1C1 sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1 - tunits = Range("tunits") - tprice = Range("tprice") - tsales = Range("tsales") + tunits = shMonthView.Range("tunits") + tprice = shMonthView.Range("tprice") + tsales = shMonthView.Range("tsales") 'reset basket shMonthUpdate.Range("U1:X10000").ClearContents Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False) ReDim adjust(12) - Call Me.crunch_array - Call Me.set_sheet + CrunchArray + SetSheet Call Me.print_basket - Call Me.set_format did_load_config = False - -End Sub - -Sub set_format() - - Dim prices As Range - Dim price_adj As Range - Dim price_set As Range - Dim vol As Range - Dim vol_adj As Range - Dim vol_set As Range - Dim val As Range - Dim val_adj As Range - Dim val_set As Range - - Set prices = shMonthView.Range("price") - Set price_adj = shMonthView.Range("PriceNewAdj") - Set price_set = shMonthView.Range("PriceFinal") - - Set vol = shMonthView.Range("units") - Set vol_adj = shMonthView.Range("QtyNewAdj") - Set vol_set = shMonthView.Range("QtyFinal") - - Set val = shMonthView.Range("sales") - Set val_adj = shMonthView.Range("SalesNewAdj") - Set val_set = shMonthView.Range("SalesFinal") - - Call Me.format_price(prices) - Call Me.set_border(prices) - Call Me.fill_yellow(price_adj) - Call Me.fill_none(price_set) - - Call Me.format_number(vol) - Call Me.set_border(vol) - Call Me.fill_yellow(vol_adj) - Call Me.fill_none(vol_set) - - Call Me.format_number(val) - Call Me.set_border(val) - Call Me.fill_yellow(val_adj) - Call Me.fill_none(val_set) - -End Sub - -Sub set_border(ByRef targ As Range) - - targ.Borders(xlDiagonalDown).LineStyle = xlNone - targ.Borders(xlDiagonalUp).LineStyle = xlNone - With targ.Borders(xlEdgeLeft) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With - With targ.Borders(xlEdgeTop) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With - With targ.Borders(xlEdgeBottom) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With - With targ.Borders(xlEdgeRight) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With - With targ.Borders(xlInsideVertical) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With - With targ.Borders(xlInsideHorizontal) - .LineStyle = xlContinuous - .ColorIndex = 0 - .TintAndShade = 0 - .Weight = xlThin - End With End Sub -Sub fill_yellow(ByRef Target As Range) - - With Target.Interior - .Pattern = xlSolid - .PatternColorIndex = xlAutomatic - .ThemeColor = xlThemeColorAccent4 - .TintAndShade = 0.799981688894314 - .PatternTintAndShade = 0 - End With - -End Sub - -Sub fill_grey(ByRef Target As Range) - - - With Target.Interior - .Pattern = xlSolid - .PatternColorIndex = xlAutomatic - .ThemeColor = xlThemeColorDark1 - .TintAndShade = -0.149998474074526 - .PatternTintAndShade = 0 - End With - -End Sub - -Sub fill_none(ByRef Target As Range) - - With Target.Interior - .Pattern = xlNone - .TintAndShade = 0 - .PatternTintAndShade = 0 - End With - -End Sub - -Sub format_price(ByRef Target As Range) - - Target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" - -End Sub - -Sub format_number(ByRef Target As Range) - - Target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)" - -End Sub - -Sub build_json() +Private Sub BuildJson() Dim i As Long Dim j As Long @@ -554,9 +406,9 @@ Sub build_json() Dim list As Object load_config - + ReDim adjust(12) - + If Me.newpart Then Set np = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson())) np("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") @@ -565,17 +417,17 @@ Sub build_json() Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]") np("source") = "adj" np("type") = "new_basket" - np("tag") = shMonthView.Range("MonthTags").value + np("tag") = shMonthView.Range("MonthTag").value Set m = JsonConverter.ParseJson("{}") End If - + For pos = 1 To 12 If Me.newpart Then If sales(pos, 5) <> 0 Then Set o = JsonConverter.ParseJson("{}") o("amount") = sales(pos, 5) o("qty") = units(pos, 5) - Set m(shMonthView.Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o)) + Set m(shMonthView.Range("OrderMonths").Cells(pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o)) End If Else 'if something is changing @@ -592,7 +444,7 @@ Sub build_json() '--ignore above comment and always use add month_vp adjust(pos)("type") = "addmonth_vp" End If - adjust(pos)("month") = shMonthView.Cells(5 + pos, 1) + adjust(pos)("month") = shMonthView.Range("OrderMonths").Cells(pos, 1) adjust(pos)("qty") = units(pos, 4) adjust(pos)("amount") = sales(pos, 4) Else @@ -610,7 +462,7 @@ Sub build_json() adjust(pos)("qty") = units(pos, 4) adjust(pos)("amount") = sales(pos, 4) '------------add this in to only scale a particular month-------------------- - adjust(pos)("scenario")("order_month") = shMonthView.Cells(5 + pos, 1) + adjust(pos)("scenario")("order_month") = shMonthView.Range("OrderMonths").Cells(pos, 1) End If adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") adjust(pos)("user") = Application.UserName @@ -620,21 +472,21 @@ Sub build_json() End If End If Next pos - + If Me.newpart Then Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m)) - np("newpart") = shMonthView.Range("B33").value - 'np("basket") = x.json_from_table(b, "basket", False) + np("newpart") = shMonthView.Range("basket").Cells(1, 1).value 'get the basket from the sheet - b = shMonthUpdate.Range("U1").CurrentRegion.value - Set m = JsonConverter.ParseJson(Utils.json_from_table(b, "basket", False)) - If UBound(b, 1) <= 2 Then - Set np("basket") = JsonConverter.ParseJson("[" & Utils.json_from_table(b, "basket", False) & "]") + Dim basket() As Variant + basket = shMonthUpdate.Range("U1").CurrentRegion.value + Set m = JsonConverter.ParseJson(Utils.json_from_table(basket, "basket", False)) + If UBound(basket, 1) <= 2 Then + Set np("basket") = JsonConverter.ParseJson("[" & Utils.json_from_table(basket, "basket", False) & "]") Else Set np("basket") = m("basket") End If End If - + If Me.newpart Then shMonthUpdate.Range("P2:P13").ClearContents shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) @@ -646,24 +498,24 @@ Sub build_json() End Sub -Sub crunch_array() +Private Sub CrunchArray() Dim i As Integer Dim j As Integer - + For i = 1 To 5 tunits(1, i) = 0 tprice(1, i) = 0 tsales(1, i) = 0 Next i - + For i = 1 To 12 For j = 1 To 5 tunits(1, j) = tunits(1, j) + units(i, j) tsales(1, j) = tsales(1, j) + sales(i, j) Next j Next i - + 'prior If tunits(1, 1) = 0 Then tprice(1, 1) = 0 @@ -690,7 +542,7 @@ Sub crunch_array() End If 'current adjust tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3)) - + End Sub @@ -701,9 +553,9 @@ Sub Cancel() End Sub Sub reset() - - Call Me.load_sheet - + + LoadSheet + End Sub Sub switch_basket() @@ -714,136 +566,131 @@ End Sub Sub print_basket() If shConfig.Range("show_basket").value = 0 Then - dumping = True + busy = True shMonthView.Range("basket").ClearContents -' Rows("20:31").Hidden = False - dumping = False + busy = False Exit Sub End If Dim i As Long Dim basket() As Variant basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) - - dumping = True - + + busy = True + shMonthView.Range("basket").ClearContents - For i = 1 To UBound(basket, 1) - shMonthView.Cells(31 + i, 2) = basket(i, 1) - shMonthView.Cells(31 + i, 6) = basket(i, 2) - shMonthView.Cells(31 + i, 12) = basket(i, 3) - shMonthView.Cells(31 + i, 17) = basket(i, 4) + For i = 2 To UBound(basket, 1) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 0).value = basket(i, 1) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 4).value = basket(i, 2) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 10).value = basket(i, 3) + shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 15).value = basket(i, 4) Next i - - Rows("21:31").Hidden = True - - dumping = False + + busy = False End Sub Sub basket_pick(ByRef Target As Range) - - Dim i As Long - - - build.part = shMonthView.Cells(Target.row, 2) - build.bill = rev_cust(shMonthView.Cells(Target.row, 6)) - build.ship = rev_cust(shMonthView.Cells(Target.row, 12)) - build.useval = False + Dim i As Long + With shMonthView + build.Initialize .Cells(Target.row, 2), rev_cust(.Cells(Target.row, 6)), rev_cust(.Cells(Target.row, 12)) build.Show - + If build.useval Then - dumping = True - 'if an empty row is selected, force it to be the next open slot - If shMonthView.Cells(Target.row, 2) = "" Then - Do Until shMonthView.Cells(Target.row + i, 2) <> "" - i = i - 1 - Loop - i = i + 1 - End If - - - shMonthView.Cells(Target.row + i, 2) = build.cbPart.value - shMonthView.Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) - shMonthView.Cells(Target.row + i, 12) = rev_cust(build.cbShip.value) - dumping = False - Set basket_touch = Selection - Call Me.get_edit_basket - Set basket_touch = Nothing - + busy = True + + .Cells(Target.row + i, 2) = build.cbPart.value + .Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) + .Cells(Target.row + i, 12) = rev_cust(build.cbShip.value) + busy = False + GetEditBasket Selection + End If - Target.Select - - + End With + Target.Select End Sub -Sub get_edit_basket() - +Private Function RemoveEmptyBasketLines() As Boolean + If busy Then Exit Function + busy = True + + RemoveEmptyBasketLines = False + Application.ScreenUpdating = False + + Dim lastRow As Long + lastRow = shMonthView.UsedRange.row + shMonthView.UsedRange.Rows.Count - 1 + + Dim i As Long + For i = lastRow To shMonthView.Range("basket").row Step -1 + If WorksheetFunction.CountA(shMonthView.Cells(i, 1).EntireRow) = 0 Then + shMonthView.Cells(i, 1).EntireRow.Delete + RemoveEmptyBasketLines = True + End If + Next + + Application.ScreenUpdating = True + + busy = False +End Function + +Private Sub GetEditBasket(touchedCells As Range) Dim i As Long Dim mix As Double Dim touch_mix As Double Dim untouched As Long Dim touch() As Boolean - - 'ReDim b(basket_rows, 3) - - i = 0 - Do Until shMonthView.Cells(33 + i, 2) = "" - i = i + 1 - Loop - i = i - 1 - - ReDim b(i, 3) - ReDim touch(i) - untouched = i + 1 - - i = 0 - mix = 0 - Do Until shMonthView.Cells(33 + i, 2) = "" - b(i, 0) = shMonthView.Cells(33 + i, 2) - b(i, 1) = shMonthView.Cells(33 + i, 6) - b(i, 2) = shMonthView.Cells(33 + i, 12) - b(i, 3) = shMonthView.Cells(33 + i, 17) - If b(i, 3) = "" Then b(i, 3) = 0 - mix = mix + b(i, 3) - If Not Intersect(basket_touch, shMonthView.Cells(33 + i, 17)) Is Nothing Then - touch_mix = touch_mix + b(i, 3) - touch(i) = True - untouched = untouched - 1 + Dim basket() As Variant + + ReDim basket(0, 3) + + i = WorksheetFunction.CountA(Range("basket").Resize(, 1)) + If i > 0 Then + + ReDim basket(i - 1, 3) + ReDim touch(i - 1) + untouched = i + + busy = True + + With shMonthView.Range("basket") + mix = 0 + For i = 1 To .Rows.Count + basket(i - 1, 0) = .Cells(i, 1) + basket(i - 1, 1) = .Cells(i, 5) + basket(i - 1, 2) = .Cells(i, 11) + basket(i - 1, 3) = .Cells(i, 16) * 1 + mix = mix + basket(i - 1, 3) + If IntersectsWith(touchedCells, .Cells(i, 16)) Then + touch_mix = touch_mix + basket(i - 1, 3) + touch(i - 1) = True + untouched = untouched - 1 + End If + Next + + 'evaluate mix changes, force to 100, and update the sheet + For i = 0 To UBound(basket, 1) + If Not touch(i) Then + If mix = touch_mix Then + basket(i, 3) = (1 - mix) / untouched + Else + basket(i, 3) = basket(i, 3) + basket(i, 3) * (1 - mix) / (mix - touch_mix) + End If + .Cells(i + 1, 16) = basket(i, 3) + End If + Next i + + End With + + busy = False + + shMonthUpdate.Range("U2:X5000").ClearContents + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True) + + If Me.newpart Then + BuildJson End If - i = i + 1 - Loop - - 'evaluate mix changes and force to 100 - For i = 0 To UBound(b, 1) - If Not touch(i) Then - If mix - touch_mix = 0 Then - b(i, 3) = (1 - mix) / untouched - Else - b(i, 3) = b(i, 3) + b(i, 3) * (1 - mix) / (mix - touch_mix) - End If - End If - Next i - - dumping = True - - 'put the mix plug back on the the sheet - For i = 0 To UBound(b, 1) - shMonthView.Cells(33 + i, 17) = b(i, 3) - Next i - - dumping = False - - shMonthUpdate.Range("U2:X5000").ClearContents - Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True) - - If Me.newpart Then - Me.build_json End If - - - End Sub @@ -851,27 +698,38 @@ End Sub Sub post_adjust() Dim i As Long Dim msg As String - If Not Me.newpart Then - msg = "Make sure at least one month has Final values for Volume, Price, and Sales." - For i = 2 To 13 - If shMonthUpdate.Cells(i, 16) <> "" Then msg = "" - Next i + + If Me.newpart Then + If WorksheetFunction.CountA(shMonthView.Range("basket").Resize(, 1)) = 0 Then + msg = "At least one row needs to be entered in the lower table. Use the New Business button or double-click in the blue row of the empty table." + End If + + If Abs(WorksheetFunction.Sum(shMonthView.Range("basket").Resize(, 1).Offset(0, 15)) - 1#) > 0.000001 Then + msg = "The mix column in the lower table does not add up to 100%. Change (or even just retype) one, and the rest will adjust" + End If + + If WorksheetFunction.CountIf(shMonthView.Range("SalesFinal"), 0) = 12 And WorksheetFunction.CountIf(shMonthView.Range("SalesNewAdj"), 0) = 12 Then + msg = "At least one month needs to have forecast data entered." + End If + Else + If WorksheetFunction.CountA(shMonthUpdate.Range("P2:P13")) = 0 Then msg = "Make sure at least one month has Final values for Volume, Price, and Sales." End If - If IsEmpty(shMonthView.Range("MonthTags").value) Then msg = "You need to specify a tag for this update." - + + If IsEmpty(shMonthView.Range("MonthTag").value) Then msg = "You need to specify a tag for this update." + If msg <> "" Then MsgBox msg, vbOKOnly Or vbExclamation Exit Sub End If - + Dim fail As Boolean Dim adjust As Object Dim jdoc As String - + If Me.newpart Then Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16)) adjust("message") = shMonthView.Range("MonthComment").value - adjust("tag") = shMonthView.Range("MonthTags").value + adjust("tag") = shMonthView.Range("MonthTag").value jdoc = JsonConverter.ConvertToJson(adjust) Call handler.request_adjust(jdoc, fail) If fail Then Exit Sub @@ -880,16 +738,15 @@ Sub post_adjust() If shMonthUpdate.Cells(i, 16) <> "" Then Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16)) adjust("message") = shMonthView.Range("MonthComment").value - adjust("tag") = shMonthView.Range("MonthTags").value + adjust("tag") = shMonthView.Range("MonthTag").value jdoc = JsonConverter.ConvertToJson(adjust) Call handler.request_adjust(jdoc, fail) If fail Then Exit Sub End If Next i End If - + shOrders.Select - 'shMonthView.Visible = xlHidden End Sub @@ -901,31 +758,31 @@ Sub build_new() Dim basket() As Variant Dim m() As Variant - dumping = True - + busy = True + m = shMonthUpdate.Range("A2:O13").FormulaR1C1 - + For i = 1 To UBound(m, 1) For j = 1 To UBound(m, 2) m(i, j) = 0 Next j Next i - + shMonthUpdate.Range("A2:O13") = m - + shMonthUpdate.Range("U2:X1000").ClearContents shMonthUpdate.Range("Z2:AC1000").ClearContents shMonthUpdate.Range("R2:S1000").ClearContents - Call Me.load_sheet - + LoadSheet + basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) - shMonthView.Cells(32, 2) = basket(1, 1) - shMonthView.Cells(32, 6) = basket(1, 2) - shMonthView.Cells(32, 12) = basket(1, 3) - shMonthView.Cells(32, 17) = basket(1, 4) +' shMonthView.Cells(32, 2) = basket(1, 1) +' shMonthView.Cells(32, 6) = basket(1, 2) +' shMonthView.Cells(32, 12) = basket(1, 3) +' shMonthView.Cells(32, 17) = basket(1, 4) Call Me.print_basket - dumping = False + busy = False End Sub @@ -935,107 +792,113 @@ Sub new_part() 'add in new part number 'retain to _month 'set new part flag - + Dim cust() As String Dim i As Long - + '---------build customer mix------------------------------------------------------------------- - + cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True) If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then MsgBox ("error building customer mix") End If - + '--------inquire for new part to join with cust mix-------------------------------------------- - + part.Show - + If Not part.useval Then Exit Sub End If - - dumping = True - - shMonthView.Range("basket").ClearContents - - For i = 1 To UBound(cust, 2) - shMonthView.Cells(32 + i, 2) = part.cbPart.value - shMonthView.Cells(32 + i, 6) = cust(0, i) - shMonthView.Cells(32 + i, 12) = cust(1, i) - shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i)) - Next i - + + busy = True + + With shMonthView.Range("basket") + .ClearContents + For i = 1 To UBound(cust, 2) + .Cells(i, 1) = part.cbPart.value + .Cells(i, 5) = cust(0, i) + .Cells(i, 11) = cust(1, i) + .Cells(i, 16) = CDbl(cust(2, i)) + Next i + End With + shConfig.Range("new_part").value = 1 - + '------copy revised basket to _month storage--------------------------------------------------- - - i = 0 - Do Until shMonthView.Cells(33 + i, 2) = "" - i = i + 1 - Loop - i = i - 1 - If i = -1 Then i = 0 - ReDim b(i, 3) - i = 0 - Do Until shMonthView.Cells(33 + i, 2) = "" - b(i, 0) = shMonthView.Cells(33 + i, 2) - b(i, 1) = shMonthView.Cells(33 + i, 6) - b(i, 2) = shMonthView.Cells(33 + i, 12) - b(i, 3) = shMonthView.Cells(33 + i, 17) - If b(i, 3) = "" Then b(i, 3) = 0 - i = i + 1 - Loop - shMonthUpdate.Range("U2:AC10000").ClearContents - Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True) - Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 26, False, False, True) - + + With shMonthView.Range("basket") + i = WorksheetFunction.CountA(.Resize(, 1)) + If i = 0 Then Exit Sub + + ReDim basket(i - 1, 3) + + For i = 1 To .Rows.Count + basket(i - 1, 0) = .Cells(i, 1) + basket(i - 1, 1) = .Cells(i, 5) + basket(i - 1, 2) = .Cells(i, 11) + basket(i - 1, 3) = .Cells(i, 16) * 1 + Next + End With + + shMonthUpdate.Range("U2:AC100000").ClearContents + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True) + Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 26, False, False, True) + '------reset volume to copy base to forecsat and clear base------------------------------------ - + units = shMonthUpdate.Range("A2:E13").FormulaR1C1 price = shMonthUpdate.Range("F2:J13").FormulaR1C1 sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 - tunits = Range("B18:F18") - tprice = Range("H18:L18") - tsales = Range("N18:R18") + tunits = shMonthView.Range("tunits") + tprice = shMonthView.Range("tprice") + tsales = shMonthView.Range("tsales") ReDim adjust(12) For i = 1 To 12 'volume - units(i, 5) = units(i, 2) - units(i, 4) = units(i, 2) + units(i, 5) = 0 'units(i, 2) + units(i, 4) = 0 'units(i, 2) units(i, 1) = 0 units(i, 2) = 0 units(i, 3) = 0 'sales - sales(i, 5) = sales(i, 2) - sales(i, 4) = sales(i, 2) + sales(i, 5) = 0 'sales(i, 2) + sales(i, 4) = 0 'sales(i, 2) sales(i, 1) = 0 sales(i, 2) = 0 sales(i, 3) = 0 'price - price(i, 5) = price(i, 2) - price(i, 4) = price(i, 2) + price(i, 5) = 0 'price(i, 2) + price(i, 4) = 0 'price(i, 2) price(i, 1) = 0 price(i, 2) = 0 price(i, 3) = 0 Next i - Call Me.crunch_array - Call Me.build_json - Call Me.set_sheet - + CrunchArray + BuildJson + SetSheet + '-------------push revised arrays back to _month, not revertable------------------------------- - + shMonthUpdate.Range("A2:E13") = units shMonthUpdate.Range("F2:J13") = price shMonthUpdate.Range("K2:o13") = sales - - + + 'force basket to show to demonstrate the part was changed shConfig.Range("show_basket").value = 1 Call Me.print_basket - dumping = False - -End Sub + busy = False + + End Sub Function newpart() As Boolean newpart = shConfig.Range("new_part").value = 1 End Function + +Private Sub Worksheet_Deactivate() + Forecasting.shMonthView.Visible = IIf(shConfig.Range("debug_mode").value, xlSheetVisible, xlSheetHidden) +End Sub + + + diff --git a/route_sql/get_pool.sql b/route_sql/get_pool.sql index f083e39..6465358 100644 --- a/route_sql/get_pool.sql +++ b/route_sql/get_pool.sql @@ -1,91 +1,92 @@ -WITH rows AS ( -SELECT - ---------customer info----------------- - bill_cust_descr - ,billto_group - ,ship_cust_descr - ,shipto_group - ,quota_rep_descr - ,director - ,segm - ,substance - ,chan - ,chansub - ---------product info------------------ - ,majg_descr - ,ming_descr - ,majs_descr - ,mins_descr - --,brand - --,part_family - ,part_group - ,branding - --,color - ,part_descr - ---------dates------------------------- - ,order_season - ,order_month - ,ship_season - ,ship_month - ,request_season - ,request_month - ,promo - --------values------------------------- - ,sum(value_loc) value_loc - ,sum(value_usd) value_usd - ,sum(cost_loc) cost_loc - ,sum(cost_usd) cost_usd - ,sum(units) units - ,version - ,iter - ,logid - ,tag - ,comment -FROM - rlarp.osm_pool -WHERE - quota_rep_descr = 'rep_replace' -GROUP BY - ---------customer info----------------- - bill_cust_descr - ,billto_group - ,ship_cust_descr - ,shipto_group - ,quota_rep_descr - ,director - ,segm - ,substance - ,chan - ,chansub - ---------product info------------------ - ,majg_descr - ,ming_descr - ,majs_descr - ,mins_descr - --,brand - --,part_family - ,part_group - ,branding - --,color - ,part_descr - ---------dates------------------------- - ,order_season - ,order_month - ,ship_season - ,ship_month - ,request_season - ,request_month - ,promo - ,version - ,iter - ,logid - ,tag - ,comment - ,substance -ORDER BY - logid ASC -) -SELECT - json_agg(row_to_json(rows)) x -FROM - rows +WITH rows AS ( +SELECT + ---------customer info----------------- + bill_cust_descr + ,billto_group + ,ship_cust_descr + ,shipto_group + ,quota_rep_descr + ,director + ,segm + ,substance + ,chan + ,chansub + ---------product info------------------ + ,majg_descr + ,ming_descr + ,majs_descr + ,mins_descr + --,brand + --,part_family + ,part_group + ,branding + --,color + ,part_descr + ---------dates------------------------- + ,order_season + ,order_month + ,ship_season + ,ship_month + ,request_season + ,request_month + ,promo + --------values------------------------- + ,sum(value_loc) value_loc + ,sum(value_usd) value_usd + ,sum(cost_loc) cost_loc + ,sum(cost_usd) cost_usd + ,sum(units) units + ,sum(pounds) pounds + ,version + ,iter + ,logid + ,tag + ,comment +FROM + rlarp.osm_pool +WHERE + quota_rep_descr = 'rep_replace' +GROUP BY + ---------customer info----------------- + bill_cust_descr + ,billto_group + ,ship_cust_descr + ,shipto_group + ,quota_rep_descr + ,director + ,segm + ,substance + ,chan + ,chansub + ---------product info------------------ + ,majg_descr + ,ming_descr + ,majs_descr + ,mins_descr + --,brand + --,part_family + ,part_group + ,branding + --,color + ,part_descr + ---------dates------------------------- + ,order_season + ,order_month + ,ship_season + ,ship_month + ,request_season + ,request_month + ,promo + ,version + ,iter + ,logid + ,tag + ,comment + ,substance +ORDER BY + logid ASC +) +SELECT + json_agg(row_to_json(rows)) x +FROM + rows