pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
480adef789
forecast_api/VBA/shMonthView.cls
PhilRunninger 85829efd1d Clean up the VBA. This coincides with version 10.0 in Teams. 
WARNING!  Do not assume the Excel file in this repo matches the VBA in
the repo. The decision was made to use Teams for managing changes to the
Excel tamplate because Git is ill-suited for binary files. The Excel
file will be updated from time to time, but only when something major
happens with the application as a whole.

1. Use the sheets' codenames to refer to them in code. This prevents
   breakage if the user changes the sheet name while working with the
   workbook.
2. Give the pivot tables proper, if not descriptive, names.
3. Simplify the code that detects a double-click in the pivot table.
4. Remove Windows_API as it was not being used.
5. Pare down TheBigOne to just the essential functions in Utils.
6. Refer to the data sources for the userforms' listboxes by using the
   worksheet.ListObjects collection.
2023-03-09 10:32:58 -05:00

1033 lines
29 KiB
OpenEdge ABL
Raw Blame History

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "shMonthView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
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 np As Object 'json dedicated to new part scenario
Private b() As Variant 'holds basket
Private did_load_config As Boolean
Private Sub sbMPP_Change()
Dim m As Worksheet
Dim i As Long
Application.ScreenUpdating = False
dumping = True
Set m = shMonthView
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
Me.mvp_adj
dumping = False
Application.ScreenUpdating = True
End Sub
Private Sub sbMPV_Change()
Dim m As Worksheet
Dim i As Long
Application.ScreenUpdating = False
dumping = True
Set m = shMonthView
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
dumping = False
Call Me.mvp_adj
Application.ScreenUpdating = True
End Sub
Private Sub tbMCOM_Change()
End Sub
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
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 shConfig.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 shConfig.Cells(6, 2) = 1 Then
Cancel = True
Call Me.basket_pick(Target)
Target.Select
End If
End Sub
Sub picker_shortcut()
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And shConfig.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 shConfig.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
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)
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()
On Error GoTo errh
Dim i As Integer
Call Me.get_sheet
Dim vp As String
vp = shMonthView.Range("Q2")
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
Next i
Me.crunch_array
Me.build_json
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 = shMonthView.Range("Q2")
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
Next i
Me.crunch_array
Me.build_json
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(shMonthUpdate.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 Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False)
'shMonthView.Range("B32:Q5000").ClearContents
If Me.newpart Then
shMonthUpdate.Range("P2:P13").ClearContents
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
dumping = False
End Sub
Sub load_sheet()
units = shMonthUpdate.Range("A2:E13").FormulaR1C1
price = shMonthUpdate.Range("F2:J13").FormulaR1C1
sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
'reset basket
shMonthUpdate.Range("U1:X10000").ClearContents
Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False)
ReDim adjust(12)
Call Me.crunch_array
Call Me.set_sheet
Call Me.print_basket
Call Me.set_format
did_load_config = False
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 = shMonthView.Range("H6:L17")
Set price_adj = shMonthView.Range("K6:K17")
Set price_set = shMonthView.Range("L6:L17")
Set vol = shMonthView.Range("B6:F17")
Set vol_adj = shMonthView.Range("E6:E17")
Set vol_set = shMonthView.Range("F6:F17")
Set val = shMonthView.Range("N6:R17")
Set val_adj = shMonthView.Range("Q6:Q17")
Set val_set = shMonthView.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()
Dim i As Long
Dim j As Long
Dim pos As Long
Dim o As Object
Dim m As Object
Dim list As Object
ReDim handler.basis(100)
i = 2
j = 0
Do While shConfig.Cells(2, i) <> ""
handler.basis(j) = shConfig.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
np("scenario")("version") = handler.plan
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj"
np("type") = "new_basket"
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(shMonthView.Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o))
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
'--ignore above comment and always use add month_vp
adjust(pos)("type") = "addmonth_vp"
End If
adjust(pos)("month") = shMonthView.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") = shMonthView.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") = handler.plan
adjust(pos)("scenario")("iter") = handler.basis
adjust(pos)("source") = "adj"
End If
End If
Next pos
If Me.newpart Then
Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m))
np("newpart") = shMonthView.Range("B33").value
'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet
b = shMonthUpdate.Range("U1").CurrentRegion.value
Set m = JsonConverter.ParseJson(Utils.json_from_table(b, "basket", False))
If UBound(b, 1) <= 2 Then
Set np("basket") = JsonConverter.ParseJson("[" & Utils.json_from_table(b, "basket", False) & "]")
Else
Set np("basket") = m("basket")
End If
End If
If Me.newpart Then
shMonthUpdate.Range("P2:P13").ClearContents
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
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()
shOrders.Select
End Sub
Sub reset()
Call Me.load_sheet
End Sub
Sub switch_basket()
If shConfig.Cells(6, 2) = 1 Then
shConfig.Cells(6, 2) = 0
Else
shConfig.Cells(6, 2) = 1
End If
Call Me.print_basket
End Sub
Sub print_basket()
'SHCONFIG.Cells(6, 2) = 1
If shConfig.Cells(6, 2) = 0 Then
dumping = True
shMonthView.Range("B32:Q10000").ClearContents
Rows("20:31").Hidden = False
dumping = False
Exit Sub
End If
Dim i As Long
Dim basket() As Variant
basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
dumping = True
shMonthView.Range("B32:Q10000").ClearContents
For i = 1 To UBound(basket, 1)
shMonthView.Cells(31 + i, 2) = basket(i, 1)
shMonthView.Cells(31 + i, 6) = basket(i, 2)
shMonthView.Cells(31 + i, 12) = basket(i, 3)
shMonthView.Cells(31 + i, 17) = basket(i, 4)
Next i
Rows("21:31").Hidden = True
dumping = False
End Sub
Sub basket_pick(ByRef Target As Range)
Dim i As Long
build.part = shMonthView.Cells(Target.row, 2)
build.bill = rev_cust(shMonthView.Cells(Target.row, 6))
build.ship = rev_cust(shMonthView.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 shMonthView.Cells(Target.row, 2) = "" Then
Do Until shMonthView.Cells(Target.row + i, 2) <> ""
i = i - 1
Loop
i = i + 1
End If
shMonthView.Cells(Target.row + i, 2) = build.cbPart.value
shMonthView.Cells(Target.row + i, 6) = rev_cust(build.cbBill.value)
shMonthView.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 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 shMonthView.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 shMonthView.Cells(33 + i, 2) = ""
b(i, 0) = shMonthView.Cells(33 + i, 2)
b(i, 1) = shMonthView.Cells(33 + i, 6)
b(i, 2) = shMonthView.Cells(33 + i, 12)
b(i, 3) = shMonthView.Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0
mix = mix + b(i, 3)
If Not Intersect(basket_touch, shMonthView.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)
shMonthView.Cells(33 + i, 17) = b(i, 3)
Next i
dumping = False
shMonthUpdate.Range("U2:X5000").ClearContents
Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True)
If Me.newpart Then
Me.build_json
End If
End Sub
Sub post_adjust()
Dim i As Long
Dim fail As Boolean
Dim adjust As Object
Dim jdoc As String
If Me.newpart Then
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16))
adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail)
If fail Then Exit Sub
Else
For i = 2 To 13
If shMonthUpdate.Cells(i, 16) <> "" Then
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16))
adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail)
If fail Then Exit Sub
End If
Next i
End If
shOrders.Select
'shMonthView.Visible = xlHidden
End Sub
Sub build_new()
shConfig.Cells(5, 2) = 1
Dim i As Long
Dim j As Long
Dim basket() As Variant
Dim m() As Variant
dumping = True
m = shMonthUpdate.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
shMonthUpdate.Range("A2:O13") = m
shMonthUpdate.Range("U2:X1000").ClearContents
shMonthUpdate.Range("Z2:AC1000").ClearContents
shMonthUpdate.Range("R2:S1000").ClearContents
Call Me.load_sheet
basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
shMonthView.Cells(32, 2) = basket(1, 1)
shMonthView.Cells(32, 6) = basket(1, 2)
shMonthView.Cells(32, 12) = basket(1, 3)
shMonthView.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-------------------------------------------------------------------
cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True)
If Not Utils.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
shMonthView.Range("B33:Q10000").ClearContents
For i = 1 To UBound(cust, 2)
shMonthView.Cells(32 + i, 2) = part.cbPart.value
shMonthView.Cells(32 + i, 6) = cust(0, i)
shMonthView.Cells(32 + i, 12) = cust(1, i)
shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i))
Next i
shConfig.Cells(7, 2) = 1
'------copy revised basket to _month storage---------------------------------------------------
i = 0
Do Until shMonthView.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 shMonthView.Cells(33 + i, 2) = ""
b(i, 0) = shMonthView.Cells(33 + i, 2)
b(i, 1) = shMonthView.Cells(33 + i, 6)
b(i, 2) = shMonthView.Cells(33 + i, 12)
b(i, 3) = shMonthView.Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0
i = i + 1
Loop
shMonthUpdate.Range("U2:AC10000").ClearContents
Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True)
Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 26, False, False, True)
'------reset volume to copy base to forecsat and clear base------------------------------------
units = shMonthUpdate.Range("A2:E13").FormulaR1C1
price = shMonthUpdate.Range("F2:J13").FormulaR1C1
sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(shMonthUpdate.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-------------------------------
shMonthUpdate.Range("A2:E13") = units
shMonthUpdate.Range("F2:J13") = price
shMonthUpdate.Range("K2:o13") = sales
'force basket to show to demonstrate the part was changed
shConfig.Cells(6, 2) = 1
Call Me.print_basket
dumping = False
End Sub
Function newpart() As Boolean
If shConfig.Cells(7, 2) = 1 Then
newpart = True
Else
newpart = False
End If
End Function
Reference in New Issue View Git Blame Copy Permalink