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

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.
This commit is contained in:
PhilRunninger 2023-03-09 10:32:58 -05:00
parent ef8a21d319
commit 85829efd1d
22 changed files with 335 additions and 3338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
VBA/JsonDebugPrint.bas
View File

@ -3,8 +3,8 @@ Option Explicit
Public Sub TestPrintJSON()
PrintJSON ParseJSON("[1,2,3]")
PrintJSON ParseJSON("[{""a"":123,""b"":[56,7,78]}]")
PrintJSON ParseJson("[1,2,3]")
PrintJSON ParseJson("[{""a"":123,""b"":[56,7,78]}]")
End Sub
' This is definitely NOT a pretty printer. It was written merely as a debugging

2730
VBA/TheBigOne.cls
View File

File diff suppressed because it is too large Load Diff

9
VBA/ThisWorkbook.cls Normal file
View File

@ -0,0 +1,9 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisWorkbook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

247
VBA/Windows_API.cls
View File

@ -1,247 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Windows_API"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardOwner Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardViewer Lib "user32" () As LongPtr
Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndNext As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
(ByVal wFormat As Long, _
ByVal lpString As String, _
ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
Private Declare PtrSafe Function GetOpenClipboardWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" _
(ByVal lpszSrc As String, _
ByVal lpszDst As String) As Long
Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare PtrSafe Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" _
(ByVal lpszSrc As String, _
ByVal lpszDst As String, _
ByVal cchDstLength As Long) As Long
Private Declare PtrSafe Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" _
(ByVal lpszSrc As String, _
ByVal lpszDst As String, _
ByVal cchDstLength As Long) As Long
Private Declare PtrSafe Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String
Private Declare PtrSafe Function CharUpperBuff Lib "user32" Alias "CharUpperBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
Private Declare PtrSafe Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String
Private Declare PtrSafe Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
Private Declare PtrSafe Function CharNext Lib "user32" Alias "CharNextA" (ByVal lpsz As String) As String
Private Declare PtrSafe Function CharPrev Lib "user32" Alias "CharPrevA" (ByVal lpszStart As String, ByVal lpszCurrent As String) As String
Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalHandle Lib "kernel32" (wMem As Any) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalReAlloc Lib "kernel32" (ByVal hMem As LongPtr, ByVal dwBytes As LongPtr, ByVal wFlags As Long) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Type POINTAPI
x As Long
Y As Long
End Type
Private Type MSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Const WM_KEYDOWN As Long = &H100
Private Const PM_REMOVE As Long = &H1
Private Const WM_CHAR As Long = &H102
Private Const GHND As Long = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 40096
Private bExitLoop As Boolean
Public Sub SetClipboard(sUniText As String)
Dim iStrPtr As LongPtr
Dim iLen As LongPtr
Dim iLock As LongPtr
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText) + 2&
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
lstrcpy iLock, StrPtr(sUniText)
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Sub ClipBoard_SetData(sUniText As String)
Dim hGlobalMemory As LongPtr
Dim lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr
Dim x As Long
hGlobalMemory = GlobalAlloc(GHND, Len(sUniText) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, sUniText)
If GlobalUnlock(hGlobalMemory) <> 0 Then
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
Exit Sub
End If
x = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox ("ruh-roh")
End If
End Sub
Public Function GetClipboard() As String
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
Dim sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(iLen \ 2& - 1&, vbNullChar)
lstrcpy StrPtr(sUniText), iLock
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard
End Function
Sub TrackKeyPressInit()
Dim msgMessage As MSG
Dim bCancel As Boolean
Dim iKeyCode As Integer
Dim lXLhwnd As Long
On Error GoTo errHandler:
Application.EnableCancelKey = xlErrorHandler
'initialize this boolean flag.
bExitLoop = False
'get the app hwnd.
lXLhwnd = FindWindow("XLMAIN", Application.Caption)
Do
WaitMessage
'check for a key press and remove it from the msg queue.
If PeekMessage _
(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
'strore the virtual key code for later use.
iKeyCode = msgMessage.wParam
'translate the virtual key code into a char msg.
TranslateMessage msgMessage
PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
WM_CHAR, PM_REMOVE
'for some obscure reason, the following
'keys are not trapped inside the event handler
'so we handle them here.
If iKeyCode = vbKeyBack Then SendKeys "{BS}"
If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
'assume the cancel argument is False.
bCancel = False
'the VBA RaiseEvent statement does not seem to return ByRef arguments
'so we call a KeyPress routine rather than a propper event handler.
Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
'if the key pressed is allowed post it to the application.
If bCancel = False Then
PostMessage _
lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
End If
End If
errHandler:
'allow the processing of other msgs.
DoEvents
Loop Until bExitLoop
End Sub
Sub StopKeyWatch()
'set this boolean flag to exit the above loop.
bExitLoop = True
End Sub
'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\characters in the Range "A1:D10" .
Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, ByVal Target As Range, Cancel As Boolean)
Const MSG As String = "Numeric Characters are not allowed in" & vbNewLine & "the Range: """
Const TITLE As String = "Invalid Entry !"
If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
If Chr(KeyAscii) Like "[0-9]" Then
MsgBox MSG & Range("A1:D10").address(False, False) _
& """ .", vbCritical, TITLE
Cancel = True
End If
End If
End Sub

14
VBA/build.frm
View File

@ -19,9 +19,6 @@ Public ship As String
Public useval As Boolean
Option Explicit
Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
@ -67,14 +64,9 @@ Private Sub UserForm_Activate()
cbBill.value = bill
cbShip.value = ship
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A2").CurrentRegion)
'cbPart.list(1).Remove
cbBill.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
'cbPart.list(1).Remove
cbShip.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
'cbPart.list(1).Remove
cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value
cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
End Sub

BIN
VBA/build.frx
View File

Binary file not shown.

12
VBA/changes.frm
View File

@ -56,17 +56,12 @@ End Sub
Private Sub tbPrint_Change()
End Sub
Private Sub UserForm_Activate()
Dim fail As Boolean
'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}}", fail)
x = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail)
If fail Then
Me.Hide
Exit Sub
@ -86,8 +81,7 @@ Private Sub UserForm_Activate()
lbHEAD.list(0, 4) = "Comment"
lbHEAD.list(0, 5) = "Sales"
lbHEAD.list(0, 6) = "id"
Dim tbo As New TheBigOne
Call tbo.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
' make it pretty
@ -126,7 +120,7 @@ Sub delete_selected()
End If
Next i
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
shOrders.PivotTables("ptOrders").PivotCache.Refresh
Me.lbHist.clear
Me.Hide

BIN
VBA/changes.frx
View File

Binary file not shown.

75
VBA/fpvt.frm
View File

@ -129,10 +129,11 @@ End Sub
Private Sub butMAdjust_Click()
Dim i As Integer
Dim fail As Boolean
For i = 1 To 12
If month(i, 10) <> "" Then
Call handler.request_adjust(CStr(month(i, 10)))
Call handler.request_adjust(CStr(month(i, 10)), fail)
End If
Next i
@ -149,14 +150,14 @@ End Sub
Private Sub cbGoSheet_Click()
Worksheets("month").tbMCOM.text = ""
Worksheets("month").sbMPV.value = 0
Worksheets("month").sbMPP.value = 0
shMonthView.tbMCOM.text = ""
shMonthView.sbMPV.value = 0
shMonthView.sbMPP.value = 0
Me.Hide
months.cbMTAG.value = ""
Worksheets("month").Visible = xlSheetVisible
Sheets("month").Select
shMonthView.cbMTAG.value = ""
shMonthView.Visible = xlSheetVisible
shMonthView.Select
End Sub
@ -229,10 +230,10 @@ Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift
End If
Next i
vtable = x.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False)
vtable = Utils.ARRAYp_TransposeVar(vSwap)
vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan
@ -265,14 +266,14 @@ Private Sub dbGETSWAP_Click()
lbSWAP.list = vSwap
'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit")
cbPLIST.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
cbPLIST.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value
'---------build change-------------
Set jswap = j
vtable = x.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False)
vtable = Utils.ARRAYp_TransposeVar(vSwap)
vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan
@ -464,10 +465,6 @@ Private Sub opPlugVol_Click()
End If
End Sub
Private Sub pickSWAP_Change()
End Sub
Private Sub sbpd_Change()
tbpd.value = sbpd.value
@ -592,13 +589,13 @@ Private Sub UserForm_Activate()
Dim ok As Boolean
Dim tags() As Variant
Me.Caption = "Forecast Adjust " & Worksheets("config").Cells(8, 2)
Me.Caption = "Forecast Adjust " & shConfig.Cells(8, 2)
Me.mp.Visible = False
Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
Call x.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.lheader = "Ready"
@ -633,7 +630,6 @@ Private Sub UserForm_Activate()
For i = 1 To sp("package")("totals").Count
Select Case sp("package")("totals")(i)("order_season")
'--------------changed this based on "totals" section----------
Case 2024
Select Case Me.iter_def(sp("package")("totals")(i)("iter"))
Case "baseline"
@ -753,7 +749,7 @@ Private Sub UserForm_Activate()
cust(i, 3) = ""
Next i
Call x.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace")
Call Utils.frmListBoxHeader(lbCUSTH, lbCUST, "Bill-To", "Replace", "Ship-To", "Replace")
'-------------load tags-------------------------------
@ -763,9 +759,9 @@ Private Sub UserForm_Activate()
tags(i - 1, 0) = sp("package")("tags")(i)
Next i
cbTAG.list = tags
Sheets("month").cbMTAG.list = tags
shMonthView.cbMTAG.list = tags
cbTAG.ListRows = UBound(tags, 1) + 1
months.cbMTAG.ListRows = UBound(tags, 1) + 1
shMonthView.cbMTAG.ListRows = UBound(tags, 1) + 1
End If
'----------reset spinner buttons----------------------
@ -777,11 +773,11 @@ Private Sub UserForm_Activate()
lbSWAP.clear
pickSWAP.value = ""
pickSWAP.text = Mid(sp("package")("basket")(1)("part_descr"), 1, 8)
pickSWAP.list = Application.transpose(Worksheets("mdata").Range("F2:F2").CurrentRegion)
cbBT.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
cbST.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
pickSWAP.list = shSupportingData.ListObjects("MOLD").DataBodyRange.value
cbBT.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
cbST.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
lbCUST.list = cust
Call x.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit")
Call Utils.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit")
'---------price volume radio button colors----------
If opPlugPrice.value = True Then
@ -899,10 +895,10 @@ Sub build_cust_swap()
Dim vtable() As Variant
Dim ptable As String
vtable = lbCUST.list
vtable = x.ARRAYp_TransposeVar(vtable)
vtable = x.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r")
vtable = x.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False)
vtable = Utils.ARRAYp_TransposeVar(vtable)
vtable = Utils.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r")
vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set cswap = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}")
cswap("scenario")("version") = handler.plan
cswap("scenario")("iter") = handler.basis
@ -1358,12 +1354,3 @@ Function iter_def(ByVal iter As String) As String
iter_def = "exclude"
End Function
Sub new_part()
End Sub
Private Sub UserForm_Initialize()
End Sub

BIN
VBA/fpvt.frx
View File

Binary file not shown.

236
VBA/handler.bas
View File

@ -5,8 +5,6 @@ Public sql As String
Public jsql As String
Public scenario As String
Public sc() As Variant
Public x As New TheBigOne
Public wapi As New Windows_API
Public data() As String
Public agg() As String
Public showprice As Boolean
@ -21,8 +19,6 @@ Sub load_fpvt()
Application.StatusBar = "retrieving selection data....."
'data = x.SHTp_Get("data", 1, 1, True)
'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30))
Dim i As Long
Dim s_tot As Object
@ -78,7 +74,6 @@ End Function
Sub pg_main_workset(rep As String)
Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API
Dim wr As String
Dim json As Object
Dim i As Long
@ -181,8 +176,8 @@ Sub pg_main_workset(rep As String)
ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents
Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
shData.Cells.ClearContents
Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True)
End Sub
@ -214,7 +209,7 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
'doc = JsonConverter.ConvertToJson(doc)
server = Sheets("config").Cells(1, 2)
server = shConfig.Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -311,16 +306,16 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
' Next i
i = 1
Do Until Sheets("data").Cells(i, 1) = ""
Do Until shData.Cells(i, 1) = ""
i = i + 1
Loop
Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True)
'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
'Call Utils.SHTp_Dump(str, shData.Name, CLng(i), 1, False, False, 28, 29, 30, 31, 32)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
shOrders.PivotTables("ptOrders").PivotCache.Refresh
End Function
@ -329,13 +324,13 @@ Sub load_config()
Dim i As Integer
Dim j As Integer
'----server to use---------------------------------------------------------
handler.server = Sheets("config").Cells(1, 2)
handler.server = shConfig.Cells(1, 2)
'---basis-----------------------------------------------------------------
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
Do While shConfig.Cells(2, i) <> ""
handler.basis(j) = shConfig.Cells(2, i)
j = j + 1
i = i + 1
Loop
@ -344,8 +339,8 @@ Sub load_config()
ReDim handler.baseline(100)
i = 2
j = 0
Do While Sheets("config").Cells(3, i) <> ""
handler.baseline(j) = Sheets("config").Cells(3, i)
Do While shConfig.Cells(3, i) <> ""
handler.baseline(j) = shConfig.Cells(3, i)
j = j + 1
i = i + 1
Loop
@ -354,14 +349,14 @@ Sub load_config()
ReDim handler.adjust(100)
i = 2
j = 0
Do While Sheets("config").Cells(4, i) <> ""
handler.adjust(j) = Sheets("config").Cells(4, i)
Do While shConfig.Cells(4, i) <> ""
handler.adjust(j) = shConfig.Cells(4, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.adjust(j - 1)
'---plan version--------------------------------------------------------------
handler.plan = Sheets("config").Cells(9, 2)
handler.plan = shConfig.Cells(9, 2)
End Sub
@ -370,104 +365,105 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
Dim j As Object
Dim i As Integer
Dim r As Long
Dim sh As Worksheet
Set sh = Sheets("_month")
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
With shMonthUpdate
For i = 0 To 12
'------------volume-------------------
sh.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
sh.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
sh.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
sh.Cells(i + 1, 4) = 0
sh.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
.Cells(1, 16) = JsonConverter.ConvertToJson(j)
'------------value----------------------
sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
sh.Cells(i + 1, 14) = 0
sh.Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
'-------------price----------------------
If i > 0 Then
'--prior--
If co_num(pkg(i, 1), 0) = 0 Then
sh.Cells(i + 1, 6) = 0
Else
sh.Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1)
End If
For i = 0 To 12
'------------volume-------------------
.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
.Cells(i + 1, 4) = 0
.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
'--base--
If co_num(pkg(i, 2), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If sh.Cells(i, 7) <> 0 Then
sh.Cells(i + 1, 7) = sh.Cells(i, 7)
'------------value----------------------
.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
.Cells(i + 1, 14) = 0
.Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
'-------------price----------------------
If i > 0 Then
'--prior--
If co_num(pkg(i, 1), 0) = 0 Then
.Cells(i + 1, 6) = 0
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 7) = 0
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
.Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1)
End If
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = (Round(pkg(i, 7), 10) + Round(pkg(i, 6), 10)) / (Round(pkg(i, 3), 10) + Round(pkg(i, 2), 10)) - (Round(pkg(i, 6), 10) / Round(pkg(i, 2), 10))
End If
'--current adjust--
sh.Cells(i + 1, 9) = 0
'--forecast--
If co_num(pkg(i, 4), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If sh.Cells(i, 10) <> 0 Then
sh.Cells(i + 1, 10) = sh.Cells(i, 10)
'--base--
If co_num(pkg(i, 2), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If .Cells(i, 7) <> 0 Then
.Cells(i + 1, 7) = .Cells(i, 7)
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
.Cells(i + 1, 7) = 0
Else
.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 10) = 0
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then
.Cells(i + 1, 8) = 0
Else
.Cells(i + 1, 8) = (Round(pkg(i, 7), 10) + Round(pkg(i, 6), 10)) / (Round(pkg(i, 3), 10) + Round(pkg(i, 2), 10)) - (Round(pkg(i, 6), 10) / Round(pkg(i, 2), 10))
End If
'--current adjust--
.Cells(i + 1, 9) = 0
'--forecast--
If co_num(pkg(i, 4), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If .Cells(i, 10) <> 0 Then
.Cells(i + 1, 10) = .Cells(i, 10)
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
.Cells(i + 1, 10) = 0
Else
.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
End If
End If
Next i
Next i
'scenario
Sheets("_month").Range("R1:S1000").ClearContents
For i = 0 To UBound(handler.sc, 1)
sh.Cells(i + 1, 18) = handler.sc(i, 0)
sh.Cells(i + 1, 19) = handler.sc(i, 1)
Next i
'basket
sh.Range("U1:AC100000").ClearContents
Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
Sheets("config").Cells(5, 2) = 0
Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 2) = 0
months.load_sheet
'scenario
.Range("R1:S1000").ClearContents
For i = 0 To UBound(handler.sc, 1)
.Cells(i + 1, 18) = handler.sc(i, 0)
.Cells(i + 1, 19) = handler.sc(i, 1)
Next i
'basket
.Range("U1:AC100000").ClearContents
Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True)
Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True)
shConfig.Cells(5, 2) = 0
shConfig.Cells(6, 2) = 0
shConfig.Cells(7, 2) = 0
shMonthView.load_sheet
End With
End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
@ -495,7 +491,7 @@ Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
Exit Function
End If
server = Sheets("config").Cells(1, 2)
server = shConfig.Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -559,12 +555,10 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant(
logid = json("x")(1)("id")
'---------loop through and get a list of each row that needs deleted?-----
Set ds = Sheets("data")
j = 0
For i = 1 To 100
If ds.Cells(1, i) = "logid" Then
If shData.Cells(1, i) = "logid" Then
j = i
Exit For
End If
@ -577,15 +571,15 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant(
End If
i = 2
While ds.Cells(i, 1) <> ""
If ds.Cells(i, j) = logid Then
ds.Rows(i).Delete
Else
i = i + 1
End If
Wend
With shData
While .Cells(i, 1) <> ""
If .Cells(i, j) = logid Then
.Rows(i).Delete
Else
i = i + 1
End If
Wend
End With
End Function
@ -610,7 +604,7 @@ Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
Exit Function
End If
server = Sheets("config").Cells(1, 2)
server = shConfig.Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All

14
VBA/openf.frm
View File

@ -25,7 +25,7 @@ Private Sub cbOK_Click()
openf.Caption = "retrieving data......"
Call handler.pg_main_workset(cbDSM.value)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
shOrders.PivotTables("ptOrders").PivotCache.Refresh
Application.StatusBar = False
openf.Hide
@ -34,18 +34,10 @@ End Sub
Private Sub UserForm_Activate()
'handler.server = "http://192.168.1.69:3000"
handler.server = Sheets("config").Cells(1, 2)
Dim x As New TheBigOne
Dim d() As String
handler.server = shConfig.Cells(1, 2)
openf.Caption = "Select a DSM"
d = x.SHTp_Get("reps", 1, 1, True)
For i = 1 To UBound(d, 2)
Call cbDSM.AddItem(d(0, i))
Next i
cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value
End Sub

BIN
VBA/openf.frx
View File

Binary file not shown.

4
VBA/part.frm
View File

@ -39,9 +39,7 @@ End Sub
Private Sub UserForm_Activate()
useval = False
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value
End Sub

BIN
VBA/part.frx
View File

Binary file not shown.

9
VBA/shConfig.cls Normal file
View File

@ -0,0 +1,9 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "shConfig"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

9
VBA/shData.cls Normal file
View File

@ -0,0 +1,9 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "shData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

9
VBA/shMonthUpdate.cls Normal file
View File

@ -0,0 +1,9 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "shMonthUpdate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

241
VBA/months.cls → VBA/shMonthView.cls
View File

@ -2,14 +2,13 @@ VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "months"
Attribute VB_Name = "shMonthView"
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
@ -31,13 +30,6 @@ Private b() As Variant 'holds basket
Private did_load_config As Boolean
Private Sub cbMTAG_Change()
End Sub
Private Sub sbMPP_Change()
Dim m As Worksheet
Dim i As Long
@ -46,7 +38,7 @@ Private Sub sbMPP_Change()
dumping = True
Set m = Sheets("month")
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)
@ -68,7 +60,7 @@ Private Sub sbMPV_Change()
dumping = True
Set m = Sheets("month")
Set m = shMonthView
m.Cells(19, 5) = sbMPV.value / 100
For i = 6 To 17
If m.Cells(i, 5) <> "" Then
@ -117,7 +109,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
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
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
@ -129,7 +121,7 @@ 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
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
@ -140,7 +132,7 @@ End Sub
Sub picker_shortcut()
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And shConfig.Cells(6, 2) = 1 Then
Call Me.basket_pick(Selection)
End If
@ -148,7 +140,7 @@ 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
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
@ -228,7 +220,7 @@ On Error GoTo errh
Dim i As Integer
Call Me.get_sheet
Dim vp As String
vp = Sheets("month").Range("Q2")
vp = shMonthView.Range("Q2")
For i = 1 To 12
If sales(i, 5) = "" Then sales(i, 5) = 0
@ -284,7 +276,7 @@ Sub ms_adj()
Dim i As Integer
Call Me.get_sheet
Dim vp As String
vp = Sheets("month").Range("Q2")
vp = shMonthView.Range("Q2")
For i = 1 To 12
If sales(i, 4) = "" Then sales(i, 4) = 0
@ -344,7 +336,7 @@ Sub get_sheet()
tprice = Range("H18:L18")
tsales = Range("N18:R18")
ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1)
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
End Sub
@ -361,15 +353,15 @@ Sub set_sheet()
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
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
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
shMonthUpdate.Range("P2:P13").ClearContents
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
@ -379,16 +371,16 @@ 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
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
Sheets("_month").Range("U1:X10000").ClearContents
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False)
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
@ -410,17 +402,17 @@ Sub set_format()
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 prices = shMonthView.Range("H6:L17")
Set price_adj = shMonthView.Range("K6:K17")
Set price_set = shMonthView.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 vol = shMonthView.Range("B6:F17")
Set vol_adj = shMonthView.Range("E6:E17")
Set vol_set = shMonthView.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")
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)
@ -541,8 +533,8 @@ Sub build_json()
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
Do While shConfig.Cells(2, i) <> ""
handler.basis(j) = shConfig.Cells(2, i)
j = j + 1
i = i + 1
Loop
@ -568,7 +560,7 @@ Sub build_json()
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))
Set m(shMonthView.Cells(5 + pos, 1).value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o))
End If
Else
'if something is changing
@ -585,7 +577,7 @@ Sub build_json()
'--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)("month") = shMonthView.Cells(5 + pos, 1)
adjust(pos)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4)
Else
@ -603,7 +595,7 @@ Sub build_json()
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)
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
@ -616,24 +608,24 @@ Sub build_json()
If Me.newpart Then
Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m))
np("newpart") = Worksheets("month").Range("B33").value
np("newpart") = shMonthView.Range("B33").value
'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet
b = Worksheets("_month").Range("U1").CurrentRegion.value
Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False))
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("[" & x.json_from_table(b, "basket", False) & "]")
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
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
shMonthUpdate.Range("P2:P13").ClearContents
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
@ -689,12 +681,11 @@ End Sub
Sub Cancel()
Sheets("Orders").Select
shOrders.Select
End Sub
Sub reset()
Call Me.load_sheet
@ -703,10 +694,10 @@ End Sub
Sub switch_basket()
If Sheets("config").Cells(6, 2) = 1 Then
Sheets("config").Cells(6, 2) = 0
If shConfig.Cells(6, 2) = 1 Then
shConfig.Cells(6, 2) = 0
Else
Sheets("config").Cells(6, 2) = 1
shConfig.Cells(6, 2) = 1
End If
Call Me.print_basket
@ -716,10 +707,10 @@ End Sub
Sub print_basket()
'Sheets("config").Cells(6, 2) = 1
If Sheets("config").Cells(6, 2) = 0 Then
'SHCONFIG.Cells(6, 2) = 1
If shConfig.Cells(6, 2) = 0 Then
dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents
shMonthView.Range("B32:Q10000").ClearContents
Rows("20:31").Hidden = False
dumping = False
Exit Sub
@ -727,16 +718,16 @@ Sub print_basket()
Dim i As Long
Dim basket() As Variant
basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents
shMonthView.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)
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
@ -751,26 +742,26 @@ Sub basket_pick(ByRef Target As Range)
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.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 Sheets("month").Cells(Target.row, 2) = "" Then
Do Until Sheets("month").Cells(Target.row + i, 2) <> ""
If shMonthView.Cells(Target.row, 2) = "" Then
Do Until shMonthView.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)
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
@ -793,7 +784,7 @@ Sub get_edit_basket()
'ReDim b(basket_rows, 3)
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
Do Until shMonthView.Cells(33 + i, 2) = ""
i = i + 1
Loop
i = i - 1
@ -804,14 +795,14 @@ Sub get_edit_basket()
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)
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, Worksheets("month").Cells(33 + i, 17)) Is Nothing Then
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
@ -834,13 +825,13 @@ Sub get_edit_basket()
'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)
shMonthView.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)
shMonthUpdate.Range("U2:X5000").ClearContents
Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True)
If Me.newpart Then
Me.build_json
@ -860,7 +851,7 @@ Sub post_adjust()
Dim jdoc As String
If Me.newpart Then
Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(2, 16))
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16))
adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust)
@ -868,8 +859,8 @@ Sub post_adjust()
If fail Then Exit Sub
Else
For i = 2 To 13
If Sheets("_month").Cells(i, 16) <> "" Then
Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(i, 16))
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)
@ -879,14 +870,14 @@ Sub post_adjust()
Next i
End If
Sheets("Orders").Select
'Worksheets("month").Visible = xlHidden
shOrders.Select
'shMonthView.Visible = xlHidden
End Sub
Sub build_new()
Worksheets("config").Cells(5, 2) = 1
shConfig.Cells(5, 2) = 1
Dim i As Long
Dim j As Long
Dim basket() As Variant
@ -894,7 +885,7 @@ Sub build_new()
dumping = True
m = Sheets("_month").Range("A2:O13").FormulaR1C1
m = shMonthUpdate.Range("A2:O13").FormulaR1C1
For i = 1 To UBound(m, 1)
For j = 1 To UBound(m, 2)
@ -902,20 +893,18 @@ Sub build_new()
Next j
Next i
Worksheets("_month").Range("A2:O13") = m
shMonthUpdate.Range("A2:O13") = m
Worksheets("_month").Range("U2:X1000").ClearContents
Worksheets("_month").Range("Z2:AC1000").ClearContents
Worksheets("_month").Range("R2:S1000").ClearContents
shMonthUpdate.Range("U2:X1000").ClearContents
shMonthUpdate.Range("Z2:AC1000").ClearContents
shMonthUpdate.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)
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
@ -934,8 +923,8 @@ Sub new_part()
'---------build customer mix-------------------------------------------------------------------
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
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
@ -949,49 +938,49 @@ Sub new_part()
dumping = True
Worksheets("month").Range("B33:Q10000").ClearContents
shMonthView.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))
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
Sheets("config").Cells(7, 2) = 1
shConfig.Cells(7, 2) = 1
'------copy revised basket to _month storage---------------------------------------------------
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
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 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)
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
Worksheets("_month").Range("U2:AC10000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
Call x.SHTp_DumpVar(b, "_month", 2, 26, False, False, True)
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 = Sheets("_month").Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1
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(Sheets("_month").Range("P1").FormulaR1C1)
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
For i = 1 To 12
'volume
units(i, 5) = units(i, 2)
@ -1018,13 +1007,13 @@ Sub new_part()
'-------------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
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
Sheets("config").Cells(6, 2) = 1
shConfig.Cells(6, 2) = 1
Call Me.print_basket
dumping = False
@ -1032,7 +1021,7 @@ End Sub
Function newpart() As Boolean
If Worksheets("config").Cells(7, 2) = 1 Then
If shConfig.Cells(7, 2) = 1 Then
newpart = True
Else
newpart = False

26
VBA/pivot.cls → VBA/shOrders.cls
View File

@ -2,26 +2,23 @@ VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot"
Attribute VB_Name = "shOrders"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Sub Worksheet_Activate()
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables("ptOrders")
Dim intersec As Range
Set intersec = Intersect(Target, pt.DataBodyRange)
If intersec Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
ElseIf intersec.address <> Target.address Then
Exit Sub
End If
@ -38,10 +35,8 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Dim cd As Object
Dim dd As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim wapi As New Windows_API
Set ri = Target.Cells.PivotCell.RowItems
Set ci = Target.Cells.PivotCell.ColumnItems
@ -51,7 +46,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
@ -69,8 +63,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub

9
VBA/shSupportingData.cls Normal file
View File

@ -0,0 +1,9 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "shSupportingData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

25
VBA/pivot1.cls → VBA/shWalk.cls
View File

@ -2,26 +2,22 @@ VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot1"
Attribute VB_Name = "shWalk"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Sub Worksheet_Activate()
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables("ptWalk")
Dim intersec As Range
Set intersec = Intersect(Target, pt.DataBodyRange)
If intersec Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
ElseIf intersec.address <> Target.address Then
Exit Sub
End If
@ -38,10 +34,8 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Dim cd As Object
Dim dd As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim wapi As New Windows_API
Set ri = Target.Cells.PivotCell.RowItems
Set ci = Target.Cells.PivotCell.ColumnItems
@ -51,7 +45,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
@ -69,8 +62,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub