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 Sub Worksheet_Change(ByVal target As Range) 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() Attribute picker_shortcut.VB_ProcData.VB_Invoke_Func = "I\n14" 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 Call Me.build_json(i) Next i Me.crunch_array 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 Call Me.build_json(i) Next i Me.crunch_array 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("R2") 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 Call Me.build_json(i) Next i Me.crunch_array 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("R2") 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 Call Me.build_json(i) Next i Me.crunch_array 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 For i = 1 To 12 Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Next i 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 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(ByVal pos As Integer) Dim i As Long Dim j As Long 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) '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 adjust(pos)("type") = "addmonth_v" 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") = "b20" adjust(pos)("scenario")("iter") = handler.basis adjust(pos)("source") = "adj" 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() Attribute switch_basket.VB_ProcData.VB_Invoke_Func = " \n14" 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("20:31").Hidden = True dumping = False End Sub Sub basket_pick(ByRef target As Range) Attribute basket_pick.VB_ProcData.VB_Invoke_Func = "I\n14" 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 b() As Variant 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) 'orig.Select End Sub Sub post_adjust() Dim i As Long For i = 2 To 13 If Sheets("_month").Cells(i, 16) <> "" Then Call handler.request_adjust(Sheets("_month").Cells(i, 16)) End If Next i 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 b() As Variant 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 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 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 Call Me.build_json(i) Next i Call Me.crunch_array Call Me.set_sheet dumping = False End Sub