pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

UI and UX Changes

Browse Source 
1. Remove/Hide Swap Part
2. Remove/Hide Swap Customer
3. Improved the location of controls on fpvt form.
4. Make user experience more intuitive on the Month sheet
5. Make more and better use of named ranges in place of hardcoded cell
   locations.
6. Added error checking to ensure Tag is entered and at least one month
   has a forecast on Month sheet.
This commit is contained in:
PhilRunninger 2023-04-05 17:51:50 -04:00
parent 12c17b0be6
commit 81174b5d57
10 changed files with 267 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
VBA/build.frx
View File

Binary file not shown.

BIN
VBA/changes.frx
View File

Binary file not shown.

50
VBA/fpvt.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00 VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
Caption = "Forecast Adjustment" Caption = "Forecast Adjustment"
ClientHeight = 8445.001 ClientHeight = 8595.001
ClientLeft = 120 ClientLeft = 120
ClientTop = 465 ClientTop = 465
ClientWidth = 8805.001 ClientWidth = 8670.001
OleObjectBlob = "fpvt.frx":0000 OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner StartUpPosition = 1 'CenterOwner
End End
@ -81,7 +81,7 @@ Private Sub butAdjust_Click()
Exit Sub Exit Sub
End If End If
If cbTAG.text = "" Then If cbTag.text = "" Then
MsgBox ("no tag was selected") MsgBox ("no tag was selected")
Exit Sub Exit Sub
End If End If
@ -112,7 +112,7 @@ Private Sub butAdjust_Click()
End If End If
Me.tbCOM = "" Me.tbCOM = ""
Me.cbTAG.text = "" Me.cbTag.text = ""
Me.Hide Me.Hide
@ -150,12 +150,12 @@ End Sub
Private Sub cbGoSheet_Click() Private Sub cbGoSheet_Click()
shMonthView.tbMCOM.text = "" shMonthView.Range("MonthComment").value = ""
shMonthView.sbMPV.value = 0 shMonthView.Cells(19, 5).value = 0
shMonthView.sbMPP.value = 0 shMonthView.Cells(19, 11).value = 0
Me.Hide Me.Hide
shMonthView.cbMTAG.value = "" shMonthView.Range("MonthTags").value = ""
shMonthView.Visible = xlSheetVisible shMonthView.Visible = xlSheetVisible
shMonthView.Select shMonthView.Select
@ -167,7 +167,7 @@ Private Sub cbTAG_Change()
Dim j As Object Dim j As Object
If tbAPI.text = "" Then tbAPI.text = "{}" If tbAPI.text = "" Then tbAPI.text = "{}"
Set j = JsonConverter.ParseJson(tbAPI.text) Set j = JsonConverter.ParseJson(tbAPI.text)
j("tag") = cbTAG.value j("tag") = cbTag.value
tbAPI.text = JsonConverter.ConvertToJson(j) tbAPI.text = JsonConverter.ConvertToJson(j)
End Sub End Sub
@ -242,7 +242,7 @@ Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift
jswap("user") = Application.UserName jswap("user") = Application.UserName
jswap("source") = "adj" jswap("source") = "adj"
jswap("message") = tbCOM.text jswap("message") = tbCOM.text
jswap("tag") = cbTAG.text jswap("tag") = cbTag.text
jswap("type") = "swap" jswap("type") = "swap"
tbAPI.text = JsonConverter.ConvertToJson(jswap) tbAPI.text = JsonConverter.ConvertToJson(jswap)
@ -282,7 +282,7 @@ Private Sub dbGETSWAP_Click()
jswap("user") = Application.UserName jswap("user") = Application.UserName
jswap("source") = "adj" jswap("source") = "adj"
jswap("message") = tbCOM.text jswap("message") = tbCOM.text
jswap("tag") = cbTAG.text jswap("tag") = cbTag.text
jswap("type") = "swap" jswap("type") = "swap"
tbAPI.text = JsonConverter.ConvertToJson(jswap) tbAPI.text = JsonConverter.ConvertToJson(jswap)
@ -587,17 +587,16 @@ Private Sub UserForm_Activate()
Dim j As Long Dim j As Long
Dim k As Long Dim k As Long
Dim ok As Boolean Dim ok As Boolean
Dim tags() As Variant ' Dim tags() As Variant
Me.Caption = "Forecast Adjust " & shConfig.Cells(8, 2) Me.Caption = "Forecast Adjust " & shConfig.Range("version").value & " Loading..."
Me.mp.Visible = False Me.mp.Visible = False
Me.fraExit.Visible = False
Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection") Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.lheader = "Ready" Me.Caption = "Forecast Adjust " & shConfig.Range("version").value
If Not ok Then If Not ok Then
fpvt.Hide fpvt.Hide
@ -753,16 +752,7 @@ Private Sub UserForm_Activate()
'-------------load tags------------------------------- '-------------load tags-------------------------------
If Not IsNull(sp("package")("tags")) Then cbTag.list = shConfig.ListObjects("TAGS").DataBodyRange.value
ReDim tags(sp("package")("tags").Count - 1, 0)
For i = 1 To sp("package")("tags").Count
tags(i - 1, 0) = sp("package")("tags")(i)
Next i
cbTAG.list = tags
shMonthView.cbMTAG.list = tags
cbTAG.ListRows = UBound(tags, 1) + 1
shMonthView.cbMTAG.ListRows = UBound(tags, 1) + 1
End If
'----------reset spinner buttons---------------------- '----------reset spinner buttons----------------------
sbpv.value = 0 sbpv.value = 0
@ -796,7 +786,7 @@ Private Sub UserForm_Activate()
Application.StatusBar = False Application.StatusBar = False
Me.mp.Visible = True Me.mp.Visible = True
Me.fraExit.Visible = True
End Sub End Sub
@ -906,7 +896,7 @@ Sub build_cust_swap()
cswap("user") = Application.UserName cswap("user") = Application.UserName
cswap("source") = "adj" cswap("source") = "adj"
cswap("message") = tbCOM.text cswap("message") = tbCOM.text
cswap("tag") = cbTAG.text cswap("tag") = cbTag.text
cswap("type") = "cust_swap" cswap("type") = "cust_swap"
Set cswap("swap") = JsonConverter.ParseJson(ptable) Set cswap("swap") = JsonConverter.ParseJson(ptable)
@ -1092,7 +1082,7 @@ Sub calc_val()
adjust("user") = Application.UserName adjust("user") = Application.UserName
adjust("source") = "adj" adjust("source") = "adj"
adjust("message") = tbCOM.text adjust("message") = tbCOM.text
adjust("tag") = cbTAG.text adjust("tag") = cbTag.text
If opEditSales Then If opEditSales Then
If opPlugVol Then If opPlugVol Then
adjust("type") = "scale_v" adjust("type") = "scale_v"
@ -1146,7 +1136,7 @@ Sub calc_price()
adjust("user") = Application.UserName adjust("user") = Application.UserName
adjust("source") = "adj" adjust("source") = "adj"
adjust("message") = tbCOM.text adjust("message") = tbCOM.text
adjust("tag") = cbTAG.text adjust("tag") = cbTag.text
adjust("version") = handler.plan adjust("version") = handler.plan
If opEditSales Then If opEditSales Then

BIN
VBA/fpvt.frx
View File

Binary file not shown.

68
VBA/handler.bas
View File

@ -98,6 +98,12 @@ Sub pg_main_workset(rep As String)
Exit Sub Exit Sub
End If End If
Set json = JsonConverter.ParseJson(wr) Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox "No data found for " & rep & "."
Exit Sub
End If
ReDim res(json("x").Count, 33) ReDim res(json("x").Count, 33)
For i = 1 To UBound(res, 1) For i = 1 To UBound(res, 1)
@ -209,7 +215,7 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss") 'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
'doc = JsonConverter.ConvertToJson(doc) 'doc = JsonConverter.ConvertToJson(doc)
server = shConfig.Cells(1, 2) server = shConfig.Range("server").value
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -322,41 +328,31 @@ End Function
Sub load_config() Sub load_config()
Dim i As Integer Dim i As Integer
Dim j As Integer
'----server to use--------------------------------------------------------- '----server to use---------------------------------------------------------
handler.server = shConfig.Cells(1, 2) handler.server = shConfig.Range("server").value
'---basis----------------------------------------------------------------- '---basis-----------------------------------------------------------------
ReDim handler.basis(100) With shConfig.ListObjects("BASIS")
i = 2 For i = 1 To .DataBodyRange.Rows.Count
j = 0 ReDim Preserve handler.basis(i - 1)
Do While shConfig.Cells(2, i) <> "" handler.basis(i - 1) = .DataBodyRange(i, 1)
handler.basis(j) = shConfig.Cells(2, i) Next
j = j + 1 End With
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
'---baseline----------------------------------------------------------------- '---baseline-----------------------------------------------------------------
ReDim handler.baseline(100) With shConfig.ListObjects("BASELINE")
i = 2 For i = 1 To .DataBodyRange.Rows.Count
j = 0 ReDim Preserve handler.baseline(i - 1)
Do While shConfig.Cells(3, i) <> "" handler.baseline(i - 1) = .DataBodyRange(i, 1)
handler.baseline(j) = shConfig.Cells(3, i) Next
j = j + 1 End With
i = i + 1
Loop
ReDim Preserve handler.baseline(j - 1)
'---adjustments----------------------------------------------------------------- '---adjustments-----------------------------------------------------------------
ReDim handler.adjust(100) With shConfig.ListObjects("ADJUST")
i = 2 For i = 1 To .DataBodyRange.Rows.Count
j = 0 ReDim Preserve handler.adjust(i - 1)
Do While shConfig.Cells(4, i) <> "" handler.adjust(i - 1) = .DataBodyRange(i, 1)
handler.adjust(j) = shConfig.Cells(4, i) Next
j = j + 1 End With
i = i + 1
Loop
ReDim Preserve handler.adjust(j - 1)
'---plan version-------------------------------------------------------------- '---plan version--------------------------------------------------------------
handler.plan = shConfig.Cells(9, 2) handler.plan = shConfig.Range("budget").value
End Sub End Sub
@ -456,9 +452,9 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
.Range("U1:AC100000").ClearContents .Range("U1:AC100000").ClearContents
Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True) Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True)
Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True) Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True)
shConfig.Cells(5, 2) = 0 shConfig.Range("rebuild").value = 0
shConfig.Cells(6, 2) = 0 shConfig.Range("show_basket").value = 0
shConfig.Cells(7, 2) = 0 shConfig.Range("new_part").value = 0
shMonthView.load_sheet shMonthView.load_sheet
@ -491,7 +487,7 @@ Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
Exit Function Exit Function
End If End If
server = shConfig.Cells(1, 2) server = shConfig.Range("server").value
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -604,7 +600,7 @@ Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
Exit Function Exit Function
End If End If
server = shConfig.Cells(1, 2) server = shConfig.Range("server").value
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All

2
VBA/openf.frm
View File

@ -34,7 +34,7 @@ End Sub
Private Sub UserForm_Activate() Private Sub UserForm_Activate()
'handler.server = "http://192.168.1.69:3000" 'handler.server = "http://192.168.1.69:3000"
handler.server = shConfig.Cells(1, 2) handler.server = shConfig.Range("server").value
openf.Caption = "Select a DSM" openf.Caption = "Select a DSM"
cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value

BIN
VBA/openf.frx
View File

Binary file not shown.

BIN
VBA/part.frx
View File

Binary file not shown.

265
VBA/shMonthView.cls
View File

@ -19,7 +19,6 @@ Private dumping As Boolean
Private vedit As String Private vedit As String
Private adjust() As Object Private adjust() As Object
Private jtext() As Variant Private jtext() As Variant
Private basejson As Object
Private rollback As Boolean Private rollback As Boolean
Private scenario() As Variant Private scenario() As Variant
Private orig As Range Private orig As Range
@ -29,21 +28,38 @@ Private np As Object 'json dedicated to new part scenario
Private b() As Variant 'holds basket Private b() As Variant 'holds basket
Private did_load_config As Boolean Private did_load_config As Boolean
Public Sub MPP_Down() ' Handler for down-triangle on price percent change.
If newpart Then Exit Sub
Private Sub sbMPP_Change() With shMonthView.Range("PricePctChange")
Dim m As Worksheet .value = WorksheetFunction.Max(-0.1, .value - 0.01)
End With
MPP_Change
End Sub
Public Sub MPP_Up() ' Handler for up-triangle on price percent change.
If newpart Then Exit Sub
With shMonthView.Range("PricePctChange")
.value = WorksheetFunction.Min(0.1, .value + 0.01)
End With
MPP_Change
End Sub
Private Sub MPP_Change()
Dim i As Long Dim i As Long
Application.ScreenUpdating = False Application.ScreenUpdating = False
dumping = True dumping = True
Set m = shMonthView With shMonthView
m.Cells(19, 11) = sbMPP.value / 100 For i = 1 To 12
For i = 6 To 17 If .Range("PriceBaseline").Cells(i) > 0 Then
m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11) .Range("PriceNewAdj").Cells(i) = .Range("PriceBaseline").Cells(i) * .Range("PricePctChange")
Next i End If
Next i
End With
Me.mvp_adj Me.mvp_adj
dumping = False dumping = False
@ -52,87 +68,91 @@ Private Sub sbMPP_Change()
End Sub End Sub
Private Sub sbMPV_Change() Public Sub MPV_Down() ' Handler for down-triangle on qty percent change.
Dim m As Worksheet If newpart Then Exit Sub
With shMonthView.Range("QtyPctChange")
.value = WorksheetFunction.Max(-0.1, .value - 0.01)
End With
MPV_Change
End Sub
Public Sub MPV_Up() ' Handler for up-triangle on qty percent change.
If newpart Then Exit Sub
With shMonthView.Range("QtyPctChange")
.value = WorksheetFunction.Min(0.1, .value + 0.01)
End With
MPV_Change
End Sub
Private Sub MPV_Change()
Dim i As Long Dim i As Long
Application.ScreenUpdating = False Application.ScreenUpdating = False
dumping = True dumping = True
Set m = shMonthView With shMonthView
m.Cells(19, 5) = sbMPV.value / 100 For i = 1 To 12
For i = 6 To 17 If .Range("QtyBaseline").Cells(i) <> 0 Then
If m.Cells(i, 5) <> "" Then .Range("QtyNewAdj").Cells(i) = .Range("QtyBaseline").Cells(i) * .Range("QtyPctChange")
m.Cells(i, 5) = (m.Cells(i, 3)) * m.Cells(19, 5) End If
End If Next i
Next i End With
dumping = False dumping = False
Call Me.mvp_adj Call Me.mvp_adj
Application.ScreenUpdating = True Application.ScreenUpdating = True
End Sub End Sub
Private Sub tbMCOM_Change()
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Private Sub Worksheet_Change(ByVal Target As Range)
'---this needs checked prior to dumping check because % increase spinners are flagged as dumps
'---this needs checked prior to dumping check becuase % increase spinners are flagged as dumps
If Not did_load_config Then If Not did_load_config Then
Call handler.load_config Call handler.load_config
did_load_config = True did_load_config = True
End If End If
If Not dumping Then If dumping Then Exit Sub
If Not Intersect(Target, Range("A1:R18")) Is Nothing Then If Not Intersect(Target, Range("A1:R18")) Is Nothing Then
If Target.Columns.Count > 1 Then If Target.Columns.Count > 1 Then
MsgBox ("you can only change one column at a time - your change will be undone") MsgBox ("you can only change one column at a time - your change will be undone")
dumping = True dumping = True
Application.Undo Application.Undo
dumping = False dumping = False
Exit Sub Exit Sub
End If
End If End If
End If
If Not Intersect(Target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj If Not Intersect(Target, Range("QtyNewAdj")) 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("QtyFinal")) 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("PriceNewAdj")) 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("PriceFinal")) 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("SalesNewAdj")) 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("SalesFinal")) 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
If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then
Set basket_touch = Target
Call Me.get_edit_basket
Set basket_touch = Nothing
End If End If
End Sub End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then
Cancel = True Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
End If End If
End Sub End Sub
Sub picker_shortcut() Sub picker_shortcut()
If Not Intersect(Selection, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then
Call Me.basket_pick(Selection) Call Me.basket_pick(Selection)
End If End If
@ -140,7 +160,7 @@ End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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 If Not Intersect(Target, Range("basket")) Is Nothing And shConfig.Range("show_basket").value = 1 Then
Cancel = True Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
@ -220,7 +240,7 @@ On Error GoTo errh
Dim i As Integer Dim i As Integer
Call Me.get_sheet Call Me.get_sheet
Dim vp As String Dim vp As String
vp = shMonthView.Range("Q2") vp = shMonthView.Range("MonthVariable")
For i = 1 To 12 For i = 1 To 12
If sales(i, 5) = "" Then sales(i, 5) = 0 If sales(i, 5) = "" Then sales(i, 5) = 0
@ -276,7 +296,7 @@ Sub ms_adj()
Dim i As Integer Dim i As Integer
Call Me.get_sheet Call Me.get_sheet
Dim vp As String Dim vp As String
vp = shMonthView.Range("Q2") vp = shMonthView.Range("MonthVariable")
For i = 1 To 12 For i = 1 To 12
If sales(i, 4) = "" Then sales(i, 4) = 0 If sales(i, 4) = "" Then sales(i, 4) = 0
@ -329,30 +349,33 @@ Sub get_sheet()
Dim i As Integer Dim i As Integer
units = Range("B6:F17") units = Range("units")
price = Range("H6:L17") price = Range("price")
sales = Range("N6:R17") sales = Range("sales")
tunits = Range("B18:F18") tunits = Range("tunits")
tprice = Range("H18:L18") tprice = Range("tprice")
tsales = Range("N18:R18") tsales = Range("tsales")
ReDim adjust(12) ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
End Sub End Sub
Private Function basejson() As Object
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
End Function
Sub set_sheet() Sub set_sheet()
Dim i As Integer Dim i As Integer
dumping = True dumping = True
Range("B6:F17") = units Range("units") = units
Range("H6:L17") = price Range("price") = price
Range("N6:R17") = sales Range("sales") = sales
Range("B18:F18").FormulaR1C1 = tunits Range("tunits").FormulaR1C1 = tunits
Range("H18:L18").FormulaR1C1 = tprice Range("tprice").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales Range("tsales").FormulaR1C1 = tsales
Range("T6:U18").ClearContents Range("scenario").ClearContents
Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False) Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False)
'shMonthView.Range("B32:Q5000").ClearContents 'shMonthView.Range("B32:Q5000").ClearContents
@ -375,9 +398,9 @@ Sub load_sheet()
price = shMonthUpdate.Range("F2:J13").FormulaR1C1 price = shMonthUpdate.Range("F2:J13").FormulaR1C1
sales = shMonthUpdate.Range("K2:O13").FormulaR1C1 sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1 scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1
tunits = Range("B18:F18") tunits = Range("tunits")
tprice = Range("H18:L18") tprice = Range("tprice")
tsales = Range("N18:R18") tsales = Range("tsales")
'reset basket 'reset basket
shMonthUpdate.Range("U1:X10000").ClearContents shMonthUpdate.Range("U1:X10000").ClearContents
Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False) Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False)
@ -402,17 +425,17 @@ Sub set_format()
Dim val_adj As Range Dim val_adj As Range
Dim val_set As Range Dim val_set As Range
Set prices = shMonthView.Range("H6:L17") Set prices = shMonthView.Range("price")
Set price_adj = shMonthView.Range("K6:K17") Set price_adj = shMonthView.Range("PriceNewAdj")
Set price_set = shMonthView.Range("L6:L17") Set price_set = shMonthView.Range("PriceFinal")
Set vol = shMonthView.Range("B6:F17") Set vol = shMonthView.Range("units")
Set vol_adj = shMonthView.Range("E6:E17") Set vol_adj = shMonthView.Range("QtyNewAdj")
Set vol_set = shMonthView.Range("F6:F17") Set vol_set = shMonthView.Range("QtyFinal")
Set val = shMonthView.Range("N6:R17") Set val = shMonthView.Range("sales")
Set val_adj = shMonthView.Range("Q6:Q17") Set val_adj = shMonthView.Range("SalesNewAdj")
Set val_set = shMonthView.Range("R6:R17") Set val_set = shMonthView.Range("SalesFinal")
Call Me.format_price(prices) Call Me.format_price(prices)
Call Me.set_border(prices) Call Me.set_border(prices)
@ -530,27 +553,19 @@ Sub build_json()
Dim m As Object Dim m As Object
Dim list As Object Dim list As Object
ReDim handler.basis(100) load_config
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) ReDim adjust(12)
If Me.newpart Then If Me.newpart Then
Set np = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson)) Set np = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson()))
np("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") np("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
np("user") = Application.UserName np("user") = Application.UserName
np("scenario")("version") = handler.plan np("scenario")("version") = handler.plan
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]") Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj" np("source") = "adj"
np("type") = "new_basket" np("type") = "new_basket"
np("tag") = cbMTAG.text np("tag") = shMonthView.Range("MonthTags").value
Set m = JsonConverter.ParseJson("{}") Set m = JsonConverter.ParseJson("{}")
End If End If
@ -565,7 +580,7 @@ Sub build_json()
Else Else
'if something is changing '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 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)) Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson()))
'if there is no existing volume on the target month but units are being added '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 If units(pos, 2) + units(pos, 3) = 0 And units(pos, 4) <> 0 Then
'add month 'add month
@ -692,26 +707,16 @@ Sub reset()
End Sub End Sub
Sub switch_basket() Sub switch_basket()
shConfig.Range("show_basket").value = 1 - shConfig.Range("show_basket").value
If shConfig.Cells(6, 2) = 1 Then
shConfig.Cells(6, 2) = 0
Else
shConfig.Cells(6, 2) = 1
End If
Call Me.print_basket Call Me.print_basket
End Sub End Sub
Sub print_basket() Sub print_basket()
'SHCONFIG.Cells(6, 2) = 1 If shConfig.Range("show_basket").value = 0 Then
If shConfig.Cells(6, 2) = 0 Then
dumping = True dumping = True
shMonthView.Range("B32:Q10000").ClearContents shMonthView.Range("basket").ClearContents
Rows("20:31").Hidden = False ' Rows("20:31").Hidden = False
dumping = False dumping = False
Exit Sub Exit Sub
End If End If
@ -722,7 +727,7 @@ Sub print_basket()
dumping = True dumping = True
shMonthView.Range("B32:Q10000").ClearContents shMonthView.Range("basket").ClearContents
For i = 1 To UBound(basket, 1) For i = 1 To UBound(basket, 1)
shMonthView.Cells(31 + i, 2) = basket(i, 1) shMonthView.Cells(31 + i, 2) = basket(i, 1)
shMonthView.Cells(31 + i, 6) = basket(i, 2) shMonthView.Cells(31 + i, 6) = basket(i, 2)
@ -844,16 +849,29 @@ End Sub
Sub post_adjust() Sub post_adjust()
Dim i As Long Dim i As Long
Dim msg As String
If Not Me.newpart Then
msg = "Make sure at least one month has Final values for Volume, Price, and Sales."
For i = 2 To 13
If shMonthUpdate.Cells(i, 16) <> "" Then msg = ""
Next i
End If
If IsEmpty(shMonthView.Range("MonthTags").value) Then msg = "You need to specify a tag for this update."
If msg <> "" Then
MsgBox msg, vbOKOnly Or vbExclamation
Exit Sub
End If
Dim fail As Boolean Dim fail As Boolean
Dim adjust As Object Dim adjust As Object
Dim jdoc As String Dim jdoc As String
If Me.newpart Then If Me.newpart Then
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16)) Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16))
adjust("message") = Me.tbMCOM.text adjust("message") = shMonthView.Range("MonthComment").value
adjust("tag") = Me.cbMTAG.text adjust("tag") = shMonthView.Range("MonthTags").value
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail) Call handler.request_adjust(jdoc, fail)
If fail Then Exit Sub If fail Then Exit Sub
@ -861,8 +879,8 @@ Sub post_adjust()
For i = 2 To 13 For i = 2 To 13
If shMonthUpdate.Cells(i, 16) <> "" Then If shMonthUpdate.Cells(i, 16) <> "" Then
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16)) Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16))
adjust("message") = Me.tbMCOM.text adjust("message") = shMonthView.Range("MonthComment").value
adjust("tag") = Me.cbMTAG.text adjust("tag") = shMonthView.Range("MonthTags").value
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
Call handler.request_adjust(jdoc, fail) Call handler.request_adjust(jdoc, fail)
If fail Then Exit Sub If fail Then Exit Sub
@ -877,7 +895,7 @@ End Sub
Sub build_new() Sub build_new()
shConfig.Cells(5, 2) = 1 shConfig.Range("rebuild").value = 1
Dim i As Long Dim i As Long
Dim j As Long Dim j As Long
Dim basket() As Variant Dim basket() As Variant
@ -938,7 +956,7 @@ Sub new_part()
dumping = True dumping = True
shMonthView.Range("B33:Q10000").ClearContents shMonthView.Range("basket").ClearContents
For i = 1 To UBound(cust, 2) For i = 1 To UBound(cust, 2)
shMonthView.Cells(32 + i, 2) = part.cbPart.value shMonthView.Cells(32 + i, 2) = part.cbPart.value
@ -947,7 +965,7 @@ Sub new_part()
shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i)) shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i))
Next i Next i
shConfig.Cells(7, 2) = 1 shConfig.Range("new_part").value = 1
'------copy revised basket to _month storage--------------------------------------------------- '------copy revised basket to _month storage---------------------------------------------------
@ -980,7 +998,6 @@ Sub new_part()
tprice = Range("H18:L18") tprice = Range("H18:L18")
tsales = Range("N18:R18") tsales = Range("N18:R18")
ReDim adjust(12) ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
For i = 1 To 12 For i = 1 To 12
'volume 'volume
units(i, 5) = units(i, 2) units(i, 5) = units(i, 2)
@ -1013,20 +1030,12 @@ Sub new_part()
'force basket to show to demonstrate the part was changed 'force basket to show to demonstrate the part was changed
shConfig.Cells(6, 2) = 1 shConfig.Range("show_basket").value = 1
Call Me.print_basket Call Me.print_basket
dumping = False dumping = False
End Sub End Sub
Function newpart() As Boolean Function newpart() As Boolean
newpart = shConfig.Range("new_part").value = 1
If shConfig.Cells(7, 2) = 1 Then
newpart = True
Else
newpart = False
End If
End Function End Function

148
VBA/shWalk.cls
View File

@ -7,108 +7,108 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True Attribute VB_Exposed = True
' Option Explicit 'Option Explicit
' '
' Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Dim pt As PivotTable ' Dim pt As PivotTable
' Set pt = ActiveSheet.PivotTables("ptWalk") ' Set pt = ActiveSheet.PivotTables("ptWalk")
' Dim intersec As Range ' Dim intersec As Range
' Set intersec = Intersect(Target, pt.DataBodyRange) ' Set intersec = Intersect(Target, pt.DataBodyRange)
' '
' If intersec Is Nothing Then ' If intersec Is Nothing Then
' Exit Sub ' Exit Sub
' ElseIf intersec.address <> Target.address Then ' ElseIf intersec.address <> Target.address Then
' Exit Sub ' Exit Sub
' End If ' End If
' '
' Cancel = True ' Cancel = True
' '
' Dim i As Long ' Dim i As Long
' Dim j As Long ' Dim j As Long
' Dim k As Long ' Dim k As Long
' '
' Dim ri As PivotItemList ' Dim ri As PivotItemList
' Dim ci As PivotItemList ' Dim ci As PivotItemList
' Dim df As Object ' Dim df As Object
' Dim rd As Object ' Dim rd As Object
' Dim cd As Object ' Dim cd As Object
' Dim dd As Object ' Dim dd As Object
' '
' Dim pf As PivotField ' Dim pf As PivotField
' Dim pi As PivotItem ' Dim pi As PivotItem
' '
' Set ri = Target.Cells.PivotCell.RowItems ' Set ri = Target.Cells.PivotCell.RowItems
' Set ci = Target.Cells.PivotCell.ColumnItems ' Set ci = Target.Cells.PivotCell.ColumnItems
' Set df = Target.Cells.PivotCell.DataField ' Set df = Target.Cells.PivotCell.DataField
' '
' Set rd = Target.Cells.PivotTable.RowFields ' Set rd = Target.Cells.PivotTable.RowFields
' Set cd = Target.Cells.PivotTable.ColumnFields ' Set cd = Target.Cells.PivotTable.ColumnFields
' '
' ReDim handler.sc(ri.Count, 1) ' ReDim handler.sc(ri.Count, 1)
' '
' handler.sql = "" ' handler.sql = ""
' handler.jsql = "" ' handler.jsql = ""
' '
' For i = 1 To ri.Count ' For i = 1 To ri.Count
' If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND " ' If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
' If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & "," ' If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
' handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'" ' handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
' jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """" ' jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
' handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name ' handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
' handler.sc(i - 1, 1) = ri(i).Name ' handler.sc(i - 1, 1) = ri(i).Name
' Next i ' Next i
' '
' scenario = "{" & handler.jsql & "}" ' scenario = "{" & handler.jsql & "}"
' '
' Call handler.load_config ' Call handler.load_config
' Call handler.load_fpvt ' Call handler.load_fpvt
' '
' End Sub 'End Sub
' '
' Function piv_pos(list As Object, target_pos As Long) As Long 'Function piv_pos(list As Object, target_pos As Long) As Long
' '
' Dim i As Long ' Dim i As Long
' '
' For i = 1 To list.Count ' For i = 1 To list.Count
' If list(i).Position = target_pos Then ' If list(i).Position = target_pos Then
' piv_pos = i ' piv_pos = i
' Exit Function ' Exit Function
' End If ' End If
' Next i ' Next i
' 'should not get to this point ' 'should not get to this point
' '
' End Function 'End Function
' '
' Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer 'Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
' '
' Dim i As Integer ' Dim i As Integer
' '
' For i = 1 To pt.PivotFields.Count ' For i = 1 To pt.PivotFields.Count
' If pt.PivotFields(i).Name = field_name Then ' If pt.PivotFields(i).Name = field_name Then
' piv_fld_index = i ' piv_fld_index = i
' Exit Function ' Exit Function
' End If ' End If
' Next i ' Next i
' '
' End Function 'End Function
' '
' Function escape_json(ByVal text As String) As String 'Function escape_json(ByVal text As String) As String
' '
' text = Replace(text, "'", "''") ' text = Replace(text, "'", "''")
' text = Replace(text, """", "\""") ' text = Replace(text, """", "\""")
' If text = "(blank)" Then text = "" ' If text = "(blank)" Then text = ""
' escape_json = text ' escape_json = text
' '
' End Function 'End Function
' '
' Function escape_sql(ByVal text As String) As String 'Function escape_sql(ByVal text As String) As String
' '
' text = Replace(text, "'", "''") ' text = Replace(text, "'", "''")
' text = Replace(text, """", """""") ' text = Replace(text, """", """""")
' If text = "(blank)" Then text = "" ' If text = "(blank)" Then text = ""
' escape_sql = text ' escape_sql = text
' '
' End Function 'End Function
' '
' '