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 Sub Worksheet_Change(ByVal target As Range)

    
    If Not dumping 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 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
            
    End If
    
    'Call Me.set_format
    

End Sub

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()

    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)), 6) <> Round(sales(i, 4), 6) 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
    
        
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("{""scenario"":" & 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
    Range("T6:U18").FormulaR1C1 = scenario
    
    Sheets("month").Range("B32:Q5000").ClearContents
    
    For i = 1 To 12
        Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
    Next i
    
    ActiveWindow.FreezePanes = False
    
    Rows("19:32").Hidden = False
    
    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")
    ReDim adjust(12)
    Me.crunch_array
    Me.set_sheet
    
    

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_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)

    '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)("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 the target price is diferent from the average and a month is being added
                adjust(pos)("type") = "scale_vp"
            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)
        End If
    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
    tprice(1, 1) = tsales(1, 1) / tunits(1, 1)
    'base
    tprice(1, 2) = tsales(1, 2) / tunits(1, 2)
    'forecast
    If tunits(1, 5) <> 0 Then
        tprice(1, 5) = tsales(1, 5) / tunits(1, 5)
    Else
        tprice(1, 5) = 0
    End If
    'adjust
    tprice(1, 3) = (tsales(1, 2) + tsales(1, 3)) / (tunits(1, 2) + tunits(1, 3)) - tprice(1, 2)
    '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 show_basket()

    Dim i As Long
    Dim basket() As Variant
    basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
    
    dumping = True
    
    Application.ScreenUpdating = False
    
    Set orig = Selection
    
    ActiveWindow.FreezePanes = False
    
    
    For i = 1 To UBound(basket, 1) - 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:20").Select
    ActiveWindow.FreezePanes = True
    
    Rows("20:31").Select
    Selection.EntireRow.Hidden = True
    
    orig.Select
    
    Application.ScreenUpdating = True
    
    dumping = False
    

End Sub