VBA/months.cls

1044 lines
29 KiB
OpenEdge ABL
Raw Normal View History

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
2020-03-05 01:08:10 -05:00
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
2019-03-18 15:29:40 -04:00
Private rollback As Boolean
2019-03-19 01:03:43 -04:00
Private scenario() As Variant
Private orig As Range
2019-03-19 15:43:31 -04:00
Private basket_touch As Range
2019-03-19 16:46:56 -04:00
Private showbasket As Boolean
Private np As Object 'json dedicated to new part scenario
2019-03-22 04:56:39 -04:00
Private b() As Variant 'holds basket
2020-02-19 23:03:48 -05:00
Private did_load_config As Boolean
2020-02-18 02:07:38 -05:00
Private Sub cbMTAG_Change()
2020-03-03 23:22:13 -05:00
End Sub
2020-02-18 02:07:38 -05:00
Private Sub sbMPP_Change()
Dim m As Worksheet
Dim i As Long
Application.ScreenUpdating = False
2020-02-18 17:04:03 -05:00
dumping = True
2020-02-18 02:07:38 -05:00
Set m = Sheets("month")
m.Cells(19, 11) = sbMPP.value / 100
For i = 6 To 17
m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11)
Next i
2020-02-18 17:04:03 -05:00
Me.mvp_adj
dumping = False
2020-02-18 02:07:38 -05:00
Application.ScreenUpdating = True
End Sub
Private Sub sbMPV_Change()
Dim m As Worksheet
Dim i As Long
Application.ScreenUpdating = False
2020-02-18 17:04:03 -05:00
dumping = True
2020-02-18 02:07:38 -05:00
Set m = Sheets("month")
m.Cells(19, 5) = sbMPV.value / 100
For i = 6 To 17
If m.Cells(i, 5) <> "" Then
m.Cells(i, 5) = (m.Cells(i, 3)) * m.Cells(19, 5)
End If
Next i
2020-02-18 17:04:03 -05:00
dumping = False
Call Me.mvp_adj
2020-02-18 02:07:38 -05:00
Application.ScreenUpdating = True
End Sub
Private Sub tbMCOM_Change()
End Sub
2020-02-19 23:03:48 -05:00
Private Sub Worksheet_Change(ByVal Target As Range)
'---this needs checked prior to dumping check becuase % increase spinners are flagged as dumps
If Not did_load_config Then
Call handler.load_config
did_load_config = True
End If
If Not dumping Then
2020-02-19 23:03:48 -05:00
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
2019-03-19 15:43:31 -04:00
End If
End If
2020-02-19 23:03:48 -05:00
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
2020-02-19 23:03:48 -05:00
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
Set basket_touch = Target
2019-03-19 15:43:31 -04:00
Call Me.get_edit_basket
Set basket_touch = Nothing
2019-03-19 15:43:31 -04:00
End If
End If
End Sub
2020-03-05 01:08:10 -05:00
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
2019-03-19 16:46:56 -04:00
2020-02-19 23:03:48 -05:00
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
2020-03-05 01:08:10 -05:00
Cancel = True
2020-02-19 23:03:48 -05:00
Call Me.basket_pick(Target)
Target.Select
End If
2019-03-19 16:46:56 -04:00
End Sub
2019-03-20 01:43:18 -04:00
Sub picker_shortcut()
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
Call Me.basket_pick(Selection)
2019-03-20 01:43:18 -04:00
End If
End Sub
2020-03-05 01:08:10 -05:00
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
2020-02-19 23:03:48 -05:00
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
2020-03-05 01:08:10 -05:00
Cancel = True
2020-02-19 23:03:48 -05:00
Call Me.basket_pick(Target)
Target.Select
End If
2019-03-19 01:03:43 -04:00
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
2020-02-14 02:27:01 -05:00
rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8))
Else
2020-02-14 02:27:01 -05:00
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)
2019-03-19 01:03:43 -04:00
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)
2019-03-19 01:03:43 -04:00
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()
2019-03-20 01:43:18 -04:00
On Error GoTo errh
Dim i As Integer
Call Me.get_sheet
2019-03-18 15:29:40 -04:00
Dim vp As String
2019-04-03 04:45:51 -04:00
vp = Sheets("month").Range("Q2")
For i = 1 To 12
2019-03-19 01:03:43 -04:00
If sales(i, 5) = "" Then sales(i, 5) = 0
2019-03-20 01:43:18 -04:00
If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 2) <> Round(sales(i, 4), 2) Then
2019-03-18 15:29:40 -04:00
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
2019-03-18 15:29:40 -04:00
Me.set_sheet
2019-03-20 01:43:18 -04:00
errh:
If Err.Number <> 0 Then rollback = True
2019-03-18 15:29:40 -04:00
End Sub
Sub ms_adj()
Dim i As Integer
Call Me.get_sheet
Dim vp As String
2019-03-25 16:04:04 -04:00
vp = Sheets("month").Range("Q2")
2019-03-18 15:29:40 -04:00
For i = 1 To 12
2019-03-19 01:03:43 -04:00
If sales(i, 4) = "" Then sales(i, 4) = 0
2019-03-18 15:29:40 -04:00
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
2019-03-18 15:29:40 -04:00
Me.crunch_array
Me.build_json
2019-03-18 15:29:40 -04:00
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)
2019-03-20 01:43:18 -04:00
Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1)
End Sub
Sub set_sheet()
2019-03-15 16:42:27 -04:00
Dim i As Integer
2019-03-15 16:42:27 -04:00
dumping = True
Range("B6:F17") = units
Range("H6:L17") = price
Range("N6:R17") = sales
2019-03-15 16:42:27 -04:00
Range("B18:F18").FormulaR1C1 = tunits
Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales
2019-03-19 10:57:56 -04:00
Range("T6:U18").ClearContents
2020-03-05 01:08:10 -05:00
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False)
2019-03-19 15:43:31 -04:00
'Sheets("month").Range("B32:Q5000").ClearContents
If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
2019-03-19 01:03:43 -04:00
dumping = False
End Sub
2019-03-15 10:44:45 -04:00
Sub load_sheet()
units = Sheets("_month").Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1
2019-03-19 01:03:43 -04:00
scenario = Sheets("_month").Range("R1:S13").FormulaR1C1
2019-03-15 16:42:27 -04:00
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
2019-03-19 15:43:31 -04:00
'reset basket
2019-03-20 12:47:01 -04:00
Sheets("_month").Range("U1:X10000").ClearContents
2020-03-05 01:08:10 -05:00
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False)
2019-03-15 16:42:27 -04:00
ReDim adjust(12)
Call Me.crunch_array
Call Me.set_sheet
Call Me.print_basket
Call Me.set_format
2020-02-19 23:03:48 -05:00
did_load_config = False
2019-03-19 01:03:43 -04:00
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
2020-02-19 23:03:48 -05:00
Sub fill_yellow(ByRef Target As Range)
2020-02-19 23:03:48 -05:00
With Target.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Sub
2020-02-19 23:03:48 -05:00
Sub fill_grey(ByRef Target As Range)
2020-02-19 23:03:48 -05:00
With Target.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End Sub
2020-02-19 23:03:48 -05:00
Sub fill_none(ByRef Target As Range)
2020-02-19 23:03:48 -05:00
With Target.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
2020-02-19 23:03:48 -05:00
Sub format_price(ByRef Target As Range)
2020-02-19 23:03:48 -05:00
Target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
End Sub
2020-02-19 23:03:48 -05:00
Sub format_number(ByRef Target As Range)
2020-02-19 23:03:48 -05:00
Target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
End Sub
Sub build_json()
2019-03-20 01:43:18 -04:00
Dim i As Long
Dim j As Long
Dim pos As Long
Dim o As Object
Dim m As Object
Dim list As Object
2019-03-20 01:43:18 -04:00
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)
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
2020-02-14 02:27:01 -05:00
np("scenario")("version") = handler.plan
2019-03-21 16:33:22 -04:00
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj"
2019-03-22 04:56:39 -04:00
np("type") = "new_basket"
2020-03-03 23:22:13 -05:00
np("tag") = cbMTAG.text
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(Worksheets("month").Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o))
2019-03-15 16:42:27 -04:00
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
2020-02-18 02:07:38 -05:00
'--ignore above comment and always use add month_vp
adjust(pos)("type") = "addmonth_vp"
End If
adjust(pos)("month") = Worksheets("month").Cells(5 + pos, 1)
adjust(pos)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4)
2019-03-20 01:43:18 -04:00
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)
2019-03-20 01:43:18 -04:00
End If
adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
adjust(pos)("user") = Application.UserName
2020-02-14 02:27:01 -05:00
adjust(pos)("scenario")("version") = handler.plan
adjust(pos)("scenario")("iter") = handler.basis
adjust(pos)("source") = "adj"
2019-03-15 16:42:27 -04:00
End If
End If
Next pos
If Me.newpart Then
Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m))
2019-03-21 16:33:22 -04:00
np("newpart") = Worksheets("month").Range("B33").value
2019-03-22 04:56:39 -04:00
'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet
b = Worksheets("_month").Range("U1").CurrentRegion.value
2020-03-05 01:08:10 -05:00
Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False))
2019-03-22 04:56:39 -04:00
If UBound(b, 1) <= 2 Then
2020-03-05 01:08:10 -05:00
Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]")
2019-03-22 04:56:39 -04:00
Else
Set np("basket") = m("basket")
End If
End If
If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
End Sub
Sub crunch_array()
Dim i As Integer
2019-03-15 16:42:27 -04:00
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
2019-03-15 16:42:27 -04:00
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
2019-03-15 10:44:45 -04:00
'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
2019-03-18 15:29:40 -04:00
If tunits(1, 5) <> 0 Then
tprice(1, 5) = tsales(1, 5) / tunits(1, 5)
Else
tprice(1, 5) = 0
End If
'adjust
2019-03-20 01:43:18 -04:00
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
2019-03-15 16:42:27 -04:00
tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3))
2019-03-15 10:44:45 -04:00
End Sub
2019-03-18 15:29:40 -04:00
2020-03-05 01:08:10 -05:00
Sub Cancel()
2019-03-18 15:29:40 -04:00
Sheets("Orders").Select
End Sub
Sub reset()
2019-03-18 15:29:40 -04:00
Call Me.load_sheet
End Sub
2019-03-19 01:03:43 -04:00
2019-03-20 12:47:01 -04:00
Sub switch_basket()
2019-03-19 01:03:43 -04:00
2019-03-19 16:46:56 -04:00
If Sheets("config").Cells(6, 2) = 1 Then
Sheets("config").Cells(6, 2) = 0
2019-03-20 12:47:01 -04:00
Else
Sheets("config").Cells(6, 2) = 1
2019-03-19 16:46:56 -04:00
End If
2019-03-20 12:47:01 -04:00
Call Me.print_basket
2019-03-19 15:43:31 -04:00
End Sub
Sub print_basket()
2019-03-20 12:47:01 -04:00
'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
2020-03-05 01:08:10 -05:00
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
2020-02-19 23:03:48 -05:00
Rows("21:31").Hidden = True
dumping = False
2019-03-19 15:43:31 -04:00
End Sub
2020-02-19 23:03:48 -05:00
Sub basket_pick(ByRef Target As Range)
2019-03-19 15:43:31 -04:00
Dim i As Long
2020-02-19 23:03:48 -05:00
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
2020-02-19 23:03:48 -05:00
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
2020-02-19 23:03:48 -05:00
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
2020-02-19 23:03:48 -05:00
Target.Select
2019-03-20 12:47:01 -04:00
2019-03-19 15:43:31 -04:00
End Sub
Sub get_edit_basket()
Dim i As Long
Dim mix As Double
Dim touch_mix As Double
2019-03-19 16:46:56 -04:00
Dim untouched As Long
2019-03-19 15:43:31 -04:00
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)
2019-03-19 16:46:56 -04:00
untouched = i + 1
2019-03-19 15:43:31 -04:00
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
2019-03-19 16:46:56 -04:00
untouched = untouched - 1
2019-03-19 15:43:31 -04:00
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
2019-03-19 16:46:56 -04:00
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
2019-03-19 15:43:31 -04:00
End If
Next i
2019-03-19 01:03:43 -04:00
2019-03-19 15:43:31 -04:00
dumping = True
2019-03-19 01:03:43 -04:00
2019-03-19 15:43:31 -04:00
'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
2019-03-19 01:03:43 -04:00
dumping = False
2019-03-19 15:43:31 -04:00
Worksheets("_month").Range("U2:X5000").ClearContents
2020-03-05 01:08:10 -05:00
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
2019-03-19 16:46:56 -04:00
2019-03-22 04:56:39 -04:00
If Me.newpart Then
Me.build_json
End If
2019-03-19 16:46:56 -04:00
2019-03-19 15:43:31 -04:00
2019-03-19 01:03:43 -04:00
End Sub
2019-03-19 15:43:31 -04:00
2019-03-20 01:43:18 -04:00
Sub post_adjust()
Dim i As Long
2019-03-21 02:58:47 -04:00
Dim fail As Boolean
2020-02-18 17:04:03 -05:00
Dim adjust As Object
Dim jdoc As String
2019-03-20 01:43:18 -04:00
2019-03-21 02:58:47 -04:00
If Me.newpart Then
2020-02-18 17:04:03 -05:00
Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(2, 16))
adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail)
2019-03-21 02:58:47 -04:00
If fail Then Exit Sub
Else
For i = 2 To 13
If Sheets("_month").Cells(i, 16) <> "" Then
2020-02-18 17:04:03 -05:00
Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(i, 16))
adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail)
2019-03-21 02:58:47 -04:00
If fail Then Exit Sub
End If
Next i
End If
2019-03-20 01:43:18 -04:00
Sheets("Orders").Select
2019-03-22 18:18:23 -04:00
'Worksheets("month").Visible = xlHidden
2019-03-20 01:43:18 -04:00
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)
2020-03-05 01:08:10 -05:00
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 i As Long
'---------build customer mix-------------------------------------------------------------------
2020-03-05 01:08:10 -05:00
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
If Not part.useval Then
Exit Sub
End If
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
If i = -1 Then i = 0
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
2020-03-05 01:08:10 -05:00
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
Next i
Call Me.crunch_array
Call Me.build_json
Call Me.set_sheet
'-------------push revised arrays back to _month, not revertable-------------------------------
Worksheets("_month").Range("A2:E13") = units
Worksheets("_month").Range("F2:J13") = price
Worksheets("_month").Range("K2:o13") = sales
'force basket to show to demonstrate the part was changed
Sheets("config").Cells(6, 2) = 1
Call Me.print_basket
dumping = False
End Sub
Function newpart() As Boolean
If Worksheets("config").Cells(7, 2) = 1 Then
newpart = True
Else
newpart = False
End If
End Function