VBA/months.cls
2019-03-20 12:47:01 -04:00

780 lines
22 KiB
OpenEdge ABL

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