VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "months" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit Private x As New TheBigOne Private units() As Variant Private price() As Variant Private sales() As Variant Private tunits() As Variant Private tprice() As Variant Private tsales() As Variant Private dumping As Boolean Private vedit As String Private adjust() As Object Private jtext() As Variant Private basejson As Object 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 Private Sub cbMTAG_Change() End Sub Private Sub sbMPP_Change() Dim m As Worksheet Dim i As Long Application.ScreenUpdating = False dumping = True Set m = Sheets("month") m.Cells(19, 11) = sbMPP.value / 100 For i = 6 To 17 m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11) Next i Me.mvp_adj dumping = False Application.ScreenUpdating = True End Sub Private Sub sbMPV_Change() Dim m As Worksheet Dim i As Long Application.ScreenUpdating = False dumping = True Set m = Sheets("month") m.Cells(19, 5) = sbMPV.value / 100 For i = 6 To 17 If m.Cells(i, 5) <> "" Then m.Cells(i, 5) = (m.Cells(i, 3)) * m.Cells(19, 5) End If Next i dumping = False Call Me.mvp_adj Application.ScreenUpdating = True End Sub Private Sub tbMCOM_Change() End Sub Private Sub Worksheet_Change(ByVal Target As Range) '---this needs checked prior to dumping check becuase % increase spinners are flagged as dumps If Not did_load_config Then Call handler.load_config did_load_config = True End If If Not dumping Then 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 End If If Not Intersect(Target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj If Not Intersect(Target, Range("F6:F17")) Is Nothing Then Call Me.mvp_set If Not Intersect(Target, Range("K6:K17")) Is Nothing Then Call Me.mvp_adj If Not Intersect(Target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set If Not Intersect(Target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj If Not Intersect(Target, Range("R6:R17")) Is Nothing Then Call Me.ms_set If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then Set basket_touch = Target Call Me.get_edit_basket Set basket_touch = Nothing End If End If End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then Cancel = True Call Me.basket_pick(Target) Target.Select End If End Sub Sub picker_shortcut() If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 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("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 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 rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - ")) End If End Function Sub mvp_set() Dim i As Integer Call Me.get_sheet For i = 1 To 12 If units(i, 5) = "" Then units(i, 5) = 0 If price(i, 5) = "" Then price(i, 5) = 0 units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) sales(i, 5) = units(i, 5) * price(i, 5) If units(i, 4) = 0 And price(i, 4) = 0 Then sales(i, 4) = 0 Else 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 End Sub Sub mvp_adj() Dim i As Integer Call Me.get_sheet For i = 1 To 12 If units(i, 4) = "" Then units(i, 4) = 0 If price(i, 4) = "" Then price(i, 4) = 0 units(i, 5) = units(i, 4) + (units(i, 2) + units(i, 3)) price(i, 5) = price(i, 4) + (price(i, 2) + price(i, 3)) sales(i, 5) = units(i, 5) * price(i, 5) If units(i, 4) = 0 And price(i, 4) = 0 Then sales(i, 4) = 0 Else 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 End Sub Sub ms_set() On Error GoTo errh Dim i As Integer Call Me.get_sheet Dim vp As String vp = Sheets("month").Range("Q2") 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 Application.Undo dumping = False Exit Sub End Select End If Next i Me.crunch_array Me.build_json Me.set_sheet 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 = Sheets("month").Range("Q2") 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 Application.Undo dumping = False Exit Sub End Select End If Next i Me.crunch_array Me.build_json Me.set_sheet End Sub Sub get_sheet() Dim i As Integer units = Range("B6:F17") price = Range("H6:L17") sales = Range("N6:R17") tunits = Range("B18:F18") tprice = Range("H18:L18") tsales = Range("N18:R18") ReDim adjust(12) Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1) End Sub Sub set_sheet() Dim i As Integer dumping = True Range("B6:F17") = units Range("H6:L17") = price Range("N6:R17") = sales Range("B18:F18").FormulaR1C1 = tunits Range("H18:L18").FormulaR1C1 = tprice Range("N18:R18").FormulaR1C1 = tsales Range("T6:U18").ClearContents Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) 'Sheets("month").Range("B32:Q5000").ClearContents If Me.newpart Then Sheets("_month").Range("P2:P13").ClearContents Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) Else For i = 1 To 12 Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If dumping = False End Sub Sub load_sheet() units = Sheets("_month").Range("A2:E13").FormulaR1C1 price = Sheets("_month").Range("F2:J13").FormulaR1C1 sales = Sheets("_month").Range("K2:O13").FormulaR1C1 scenario = Sheets("_month").Range("R1:S13").FormulaR1C1 tunits = Range("B18:F18") tprice = Range("H18:L18") tsales = Range("N18:R18") 'reset basket Sheets("_month").Range("U1:X10000").ClearContents Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False) ReDim adjust(12) Call Me.crunch_array Call Me.set_sheet 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 = Sheets("month").Range("H6:L17") Set price_adj = Sheets("month").Range("K6:K17") Set price_set = Sheets("month").Range("L6:L17") Set vol = Sheets("month").Range("B6:F17") Set vol_adj = Sheets("month").Range("E6:E17") Set vol_set = Sheets("month").Range("F6:F17") Set val = Sheets("month").Range("N6:R17") Set val_adj = Sheets("month").Range("Q6:Q17") Set val_set = Sheets("month").Range("R6:R17") 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() Dim i As Long Dim j As Long Dim pos As Long Dim o As Object Dim m As Object Dim list As Object ReDim handler.basis(100) i = 2 j = 0 Do While Sheets("config").Cells(2, i) <> "" handler.basis(j) = Sheets("config").Cells(2, i) j = j + 1 i = i + 1 Loop ReDim Preserve handler.basis(j - 1) 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") np("user") = Application.UserName np("scenario")("version") = handler.plan Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]") np("source") = "adj" np("type") = "new_basket" np("tag") = cbMTAG.text 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(Worksheets("month").Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o)) End If Else 'if something is changing If Round(units(pos, 4), 2) <> 0 Or (Round(price(pos, 4), 8) <> 0 And Round(units(pos, 5), 2) <> 0) Then Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson)) 'if there is no existing volume on the target month but units are being added If units(pos, 2) + units(pos, 3) = 0 And units(pos, 4) <> 0 Then 'add month If Round(price(pos, 5), 8) <> Round(tprice(1, 2) + tprice(1, 3), 8) Then 'if the target price is diferent from the average and a month is being added adjust(pos)("type") = "addmonth_vp" Else 'if the target price is the same as average and a month is being added '--ignore above comment and always use add month_vp adjust(pos)("type") = "addmonth_vp" End If adjust(pos)("month") = Worksheets("month").Cells(5 + pos, 1) adjust(pos)("qty") = units(pos, 4) adjust(pos)("amount") = sales(pos, 4) Else 'scale the existing volume(price) on the target month If Round(price(pos, 4), 8) <> 0 Then If Round(units(pos, 4), 2) <> 0 Then adjust(pos)("type") = "scale_vp" Else adjust(pos)("type") = "scale_p" End If Else 'if the target price is the same as average and a month is being added adjust(pos)("type") = "scale_v" End If 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") = Worksheets("month").Cells(5 + pos, 1) End If adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") adjust(pos)("user") = Application.UserName adjust(pos)("scenario")("version") = handler.plan adjust(pos)("scenario")("iter") = handler.basis adjust(pos)("source") = "adj" End If End If Next pos If Me.newpart Then Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m)) np("newpart") = Worksheets("month").Range("B33").value 'np("basket") = x.json_from_table(b, "basket", False) 'get the basket from the sheet b = Worksheets("_month").Range("U1").CurrentRegion.value Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False)) If UBound(b, 1) <= 2 Then Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]") Else Set np("basket") = m("basket") End If End If If Me.newpart Then Sheets("_month").Range("P2:P13").ClearContents Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) Else For i = 1 To 12 Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If End Sub Sub crunch_array() 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 Else tprice(1, 1) = tsales(1, 1) / tunits(1, 1) End If 'base If tunits(1, 2) = 0 Then tprice(1, 2) = 0 Else tprice(1, 2) = tsales(1, 2) / tunits(1, 2) End If 'forecast If tunits(1, 5) <> 0 Then tprice(1, 5) = tsales(1, 5) / tunits(1, 5) Else tprice(1, 5) = 0 End If 'adjust If (tunits(1, 2) + tunits(1, 3)) = 0 Then tprice(1, 3) = 0 Else tprice(1, 3) = (tsales(1, 2) + tsales(1, 3)) / (tunits(1, 2) + tunits(1, 3)) - tprice(1, 2) End If 'current adjust tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3)) End Sub Sub Cancel() Sheets("Orders").Select End Sub Sub reset() Call Me.load_sheet End Sub Sub switch_basket() If Sheets("config").Cells(6, 2) = 1 Then Sheets("config").Cells(6, 2) = 0 Else Sheets("config").Cells(6, 2) = 1 End If Call Me.print_basket End Sub Sub print_basket() 'Sheets("config").Cells(6, 2) = 1 If Sheets("config").Cells(6, 2) = 0 Then dumping = True Worksheets("month").Range("B32:Q10000").ClearContents Rows("20:31").Hidden = False dumping = False Exit Sub End If Dim i As Long Dim basket() As Variant basket = x.SHTp_get_block(Sheets("_month").Range("U1")) dumping = True Worksheets("month").Range("B32:Q10000").ClearContents For i = 1 To UBound(basket, 1) Sheets("month").Cells(31 + i, 2) = basket(i, 1) Sheets("month").Cells(31 + i, 6) = basket(i, 2) Sheets("month").Cells(31 + i, 12) = basket(i, 3) Sheets("month").Cells(31 + i, 17) = basket(i, 4) Next i Rows("21:31").Hidden = True dumping = False End Sub Sub basket_pick(ByRef Target As Range) Dim i As Long build.part = Sheets("month").Cells(Target.row, 2) build.bill = rev_cust(Sheets("month").Cells(Target.row, 6)) build.ship = rev_cust(Sheets("month").Cells(Target.row, 12)) build.useval = False build.Show If build.useval Then dumping = True 'if an empty row is selected, force it to be the next open slot If Sheets("month").Cells(Target.row, 2) = "" Then Do Until Sheets("month").Cells(Target.row + i, 2) <> "" i = i - 1 Loop i = i + 1 End If Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) Sheets("month").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 End If Target.Select End Sub Sub get_edit_basket() 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 Worksheets("month").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 Worksheets("month").Cells(33 + i, 2) = "" b(i, 0) = Worksheets("month").Cells(33 + i, 2) b(i, 1) = Worksheets("month").Cells(33 + i, 6) b(i, 2) = Worksheets("month").Cells(33 + i, 12) b(i, 3) = Worksheets("month").Cells(33 + i, 17) If b(i, 3) = "" Then b(i, 3) = 0 mix = mix + b(i, 3) If Not Intersect(basket_touch, Worksheets("month").Cells(33 + i, 17)) Is Nothing Then touch_mix = touch_mix + b(i, 3) touch(i) = True untouched = untouched - 1 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) Worksheets("month").Cells(33 + i, 17) = b(i, 3) Next i dumping = False Worksheets("_month").Range("U2:X5000").ClearContents Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) If Me.newpart Then Me.build_json End If End Sub Sub post_adjust() Dim i As Long Dim fail As Boolean Dim adjust As Object Dim jdoc As String If Me.newpart Then Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(2, 16)) adjust("message") = Me.tbMCOM.text adjust("tag") = Me.cbMTAG.text jdoc = JsonConverter.ConvertToJson(adjust) Call handler.request_adjust(jdoc, fail) If fail Then Exit Sub Else For i = 2 To 13 If Sheets("_month").Cells(i, 16) <> "" Then Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(i, 16)) adjust("message") = Me.tbMCOM.text adjust("tag") = Me.cbMTAG.text jdoc = JsonConverter.ConvertToJson(adjust) Call handler.request_adjust(jdoc, fail) If fail Then Exit Sub End If Next i End If Sheets("Orders").Select 'Worksheets("month").Visible = xlHidden End Sub Sub build_new() Worksheets("config").Cells(5, 2) = 1 Dim i As Long Dim j As Long Dim basket() As Variant Dim m() As Variant dumping = True m = Sheets("_month").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 Worksheets("_month").Range("A2:O13") = m Worksheets("_month").Range("U2:X1000").ClearContents Worksheets("_month").Range("Z2:AC1000").ClearContents Worksheets("_month").Range("R2:S1000").ClearContents Call Me.load_sheet 'Call Me.set_sheet 'Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) basket = x.SHTp_get_block(Worksheets("_month").Range("U1")) Sheets("month").Cells(32, 2) = basket(1, 1) Sheets("month").Cells(32, 6) = basket(1, 2) Sheets("month").Cells(32, 12) = basket(1, 3) Sheets("month").Cells(32, 17) = basket(1, 4) Call Me.print_basket dumping = False End Sub Sub new_part() 'keep customer mix 'add in new part number 'retain to _month 'set new part flag Dim cust() As String Dim i As Long '---------build customer mix------------------------------------------------------------------- cust = x.SHTp_Get("_month", 1, 27, True) If Not x.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 Worksheets("month").Range("B33:Q10000").ClearContents For i = 1 To UBound(cust, 2) Sheets("month").Cells(32 + i, 2) = part.cbPart.value Sheets("month").Cells(32 + i, 6) = cust(0, i) Sheets("month").Cells(32 + i, 12) = cust(1, i) Sheets("month").Cells(32 + i, 17) = CDbl(cust(2, i)) Next i Sheets("config").Cells(7, 2) = 1 '------copy revised basket to _month storage--------------------------------------------------- i = 0 Do Until Worksheets("month").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 Worksheets("month").Cells(33 + i, 2) = "" b(i, 0) = Worksheets("month").Cells(33 + i, 2) b(i, 1) = Worksheets("month").Cells(33 + i, 6) b(i, 2) = Worksheets("month").Cells(33 + i, 12) b(i, 3) = Worksheets("month").Cells(33 + i, 17) If b(i, 3) = "" Then b(i, 3) = 0 i = i + 1 Loop Worksheets("_month").Range("U2:AC10000").ClearContents Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) Call x.SHTp_DumpVar(b, "_month", 2, 26, False, False, True) '------reset volume to copy base to forecsat and clear base------------------------------------ units = Sheets("_month").Range("A2:E13").FormulaR1C1 price = Sheets("_month").Range("F2:J13").FormulaR1C1 sales = Sheets("_month").Range("K2:O13").FormulaR1C1 tunits = Range("B18:F18") tprice = Range("H18:L18") tsales = Range("N18:R18") ReDim adjust(12) Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1) For i = 1 To 12 'volume units(i, 5) = units(i, 2) units(i, 4) = 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, 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, 1) = 0 price(i, 2) = 0 price(i, 3) = 0 Next i Call Me.crunch_array Call Me.build_json Call Me.set_sheet '-------------push revised arrays back to _month, not revertable------------------------------- Worksheets("_month").Range("A2:E13") = units Worksheets("_month").Range("F2:J13") = price Worksheets("_month").Range("K2:o13") = sales 'force basket to show to demonstrate the part was changed Sheets("config").Cells(6, 2) = 1 Call Me.print_basket dumping = False End Sub Function newpart() As Boolean If Worksheets("config").Cells(7, 2) = 1 Then newpart = True Else newpart = False End If End Function