VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "shMonthView" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit 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 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 MPP_Change 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 MPP_Change End Sub Private Sub MPP_Change() Dim i As Long Application.ScreenUpdating = False dumping = True With shMonthView For i = 1 To 12 If .Range("PriceBaseline").Cells(i) > 0 Then .Range("PriceNewAdj").Cells(i) = .Range("PriceBaseline").Cells(i) * .Range("PricePctChange") End If Next i End With Me.mvp_adj dumping = 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 MPV_Change 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 MPV_Change End Sub Private Sub MPV_Change() Dim i As Long Application.ScreenUpdating = False dumping = True With shMonthView For i = 1 To 12 If .Range("QtyBaseline").Cells(i) <> 0 Then .Range("QtyNewAdj").Cells(i) = .Range("QtyBaseline").Cells(i) * .Range("QtyPctChange") End If Next i End With dumping = 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 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 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 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 Cancel = True Call Me.basket_pick(Target) Target.Select End If End Sub Sub picker_shortcut() If Not Intersect(Selection, Range("basket")) Is Nothing 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 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 = shMonthView.Range("MonthVariable") 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 = shMonthView.Range("MonthVariable") 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("units") price = Range("price") sales = Range("sales") tunits = Range("tunits") tprice = Range("tprice") tsales = Range("tsales") ReDim adjust(12) End Sub Private Function basejson() As Object Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1) End Function Sub set_sheet() 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 If Me.newpart Then shMonthUpdate.Range("P2:P13").ClearContents shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np) Else For i = 1 To 12 shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i End If dumping = False End Sub Sub load_sheet() 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") '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 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() Dim i As Long Dim j As Long Dim pos As Long Dim o As Object Dim m As Object 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") 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") = shMonthView.Range("MonthTags").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)) 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") = shMonthView.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") = shMonthView.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") = shMonthView.Range("B33").value 'np("basket") = x.json_from_table(b, "basket", False) '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) & "]") 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) Else For i = 1 To 12 shMonthUpdate.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() shOrders.Select End Sub Sub reset() Call Me.load_sheet End Sub Sub switch_basket() shConfig.Range("show_basket").value = 1 - shConfig.Range("show_basket").value Call Me.print_basket End Sub Sub print_basket() If shConfig.Range("show_basket").value = 0 Then dumping = True shMonthView.Range("basket").ClearContents ' Rows("20:31").Hidden = False dumping = False Exit Sub End If Dim i As Long Dim basket() As Variant basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1")) dumping = 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) Next i Rows("21:31").Hidden = True dumping = 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 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 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 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 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 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 End If If IsEmpty(shMonthView.Range("MonthTags").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 jdoc = JsonConverter.ConvertToJson(adjust) Call handler.request_adjust(jdoc, fail) If fail Then Exit Sub Else For i = 2 To 13 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 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 Sub build_new() shConfig.Range("rebuild").value = 1 Dim i As Long Dim j As Long Dim basket() As Variant Dim m() As Variant dumping = 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 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) 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 = 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 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) '------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") ReDim adjust(12) 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------------------------------- 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 Function newpart() As Boolean newpart = shConfig.Range("new_part").value = 1 End Function