VBA/months.cls

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