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.

Browse Source 
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() Public Sub TestPrintJSON()
PrintJSON ParseJSON("[1,2,3]") PrintJSON ParseJson("[1,2,3]")
PrintJSON ParseJSON("[{""a"":123,""b"":[56,7,78]}]") PrintJSON ParseJson("[{""a"":123,""b"":[56,7,78]}]")
End Sub End Sub
' This is definitely NOT a pretty printer. It was written merely as a debugging ' 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 Public useval As Boolean
Option Explicit Option Explicit
Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Private Sub cbBill_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode Select Case KeyCode
Case 13 Case 13
@ -67,14 +64,9 @@ Private Sub UserForm_Activate()
cbBill.value = bill cbBill.value = bill
cbShip.value = ship cbShip.value = ship
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A2").CurrentRegion) cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value
'cbPart.list(1).Remove cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
cbBill.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
'cbPart.list(1).Remove
cbShip.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion)
'cbPart.list(1).Remove
End Sub 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() Private Sub UserForm_Activate()
Dim fail As Boolean Dim fail As Boolean
'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail) '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 If fail Then
Me.Hide Me.Hide
Exit Sub Exit Sub
@ -86,8 +81,7 @@ Private Sub UserForm_Activate()
lbHEAD.list(0, 4) = "Comment" lbHEAD.list(0, 4) = "Comment"
lbHEAD.list(0, 5) = "Sales" lbHEAD.list(0, 5) = "Sales"
lbHEAD.list(0, 6) = "id" lbHEAD.list(0, 6) = "id"
Dim tbo As New TheBigOne Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
Call tbo.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
' make it pretty ' make it pretty
@ -126,7 +120,7 @@ Sub delete_selected()
End If End If
Next i Next i
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh shOrders.PivotTables("ptOrders").PivotCache.Refresh
Me.lbHist.clear Me.lbHist.clear
Me.Hide 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() Private Sub butMAdjust_Click()
Dim i As Integer Dim i As Integer
Dim fail As Boolean
For i = 1 To 12 For i = 1 To 12
If month(i, 10) <> "" Then If month(i, 10) <> "" Then
Call handler.request_adjust(CStr(month(i, 10))) Call handler.request_adjust(CStr(month(i, 10)), fail)
End If End If
Next i Next i
@ -149,14 +150,14 @@ End Sub
Private Sub cbGoSheet_Click() Private Sub cbGoSheet_Click()
Worksheets("month").tbMCOM.text = "" shMonthView.tbMCOM.text = ""
Worksheets("month").sbMPV.value = 0 shMonthView.sbMPV.value = 0
Worksheets("month").sbMPP.value = 0 shMonthView.sbMPP.value = 0
Me.Hide Me.Hide
months.cbMTAG.value = "" shMonthView.cbMTAG.value = ""
Worksheets("month").Visible = xlSheetVisible shMonthView.Visible = xlSheetVisible
Sheets("month").Select shMonthView.Select
End Sub End Sub
@ -229,10 +230,10 @@ Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift
End If End If
Next i Next i
vtable = x.ARRAYp_TransposeVar(vSwap) vtable = Utils.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable) vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False) ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set jswap("swap") = JsonConverter.ParseJson(ptable) Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan jswap("scenario")("version") = handler.plan
@ -265,14 +266,14 @@ Private Sub dbGETSWAP_Click()
lbSWAP.list = vSwap lbSWAP.list = vSwap
'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit") '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------------- '---------build change-------------
Set jswap = j Set jswap = j
vtable = x.ARRAYp_TransposeVar(vSwap) vtable = Utils.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit") vtable = Utils.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable) vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False) ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set jswap("swap") = JsonConverter.ParseJson(ptable) Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan jswap("scenario")("version") = handler.plan
@ -464,10 +465,6 @@ Private Sub opPlugVol_Click()
End If End If
End Sub End Sub
Private Sub pickSWAP_Change()
End Sub
Private Sub sbpd_Change() Private Sub sbpd_Change()
tbpd.value = sbpd.value tbpd.value = sbpd.value
@ -592,13 +589,13 @@ Private Sub UserForm_Activate()
Dim ok As Boolean Dim ok As Boolean
Dim tags() As Variant 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.mp.Visible = False
Me.lheader = "Loading..." Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) 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" Me.lheader = "Ready"
@ -633,7 +630,6 @@ Private Sub UserForm_Activate()
For i = 1 To sp("package")("totals").Count For i = 1 To sp("package")("totals").Count
Select Case sp("package")("totals")(i)("order_season") Select Case sp("package")("totals")(i)("order_season")
'--------------changed this based on "totals" section----------
Case 2024 Case 2024
Select Case Me.iter_def(sp("package")("totals")(i)("iter")) Select Case Me.iter_def(sp("package")("totals")(i)("iter"))
Case "baseline" Case "baseline"
@ -753,7 +749,7 @@ Private Sub UserForm_Activate()
cust(i, 3) = "" cust(i, 3) = ""
Next i 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------------------------------- '-------------load tags-------------------------------
@ -763,9 +759,9 @@ Private Sub UserForm_Activate()
tags(i - 1, 0) = sp("package")("tags")(i) tags(i - 1, 0) = sp("package")("tags")(i)
Next i Next i
cbTAG.list = tags cbTAG.list = tags
Sheets("month").cbMTAG.list = tags shMonthView.cbMTAG.list = tags
cbTAG.ListRows = UBound(tags, 1) + 1 cbTAG.ListRows = UBound(tags, 1) + 1
months.cbMTAG.ListRows = UBound(tags, 1) + 1 shMonthView.cbMTAG.ListRows = UBound(tags, 1) + 1
End If End If
'----------reset spinner buttons---------------------- '----------reset spinner buttons----------------------
@ -777,11 +773,11 @@ Private Sub UserForm_Activate()
lbSWAP.clear lbSWAP.clear
pickSWAP.value = "" pickSWAP.value = ""
pickSWAP.text = Mid(sp("package")("basket")(1)("part_descr"), 1, 8) pickSWAP.text = Mid(sp("package")("basket")(1)("part_descr"), 1, 8)
pickSWAP.list = Application.transpose(Worksheets("mdata").Range("F2:F2").CurrentRegion) pickSWAP.list = shSupportingData.ListObjects("MOLD").DataBodyRange.value
cbBT.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) cbBT.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
cbST.list = Application.transpose(Worksheets("mdata").Range("D2:D2").CurrentRegion) cbST.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.value
lbCUST.list = cust 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---------- '---------price volume radio button colors----------
If opPlugPrice.value = True Then If opPlugPrice.value = True Then
@ -899,10 +895,10 @@ Sub build_cust_swap()
Dim vtable() As Variant Dim vtable() As Variant
Dim ptable As String Dim ptable As String
vtable = lbCUST.list vtable = lbCUST.list
vtable = x.ARRAYp_TransposeVar(vtable) vtable = Utils.ARRAYp_TransposeVar(vtable)
vtable = x.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r") vtable = Utils.ARRAYp_zerobased_addheader(vtable, "bill", "bill_r", "ship", "ship_r")
vtable = x.ARRAYp_TransposeVar(vtable) vtable = Utils.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", True, False) ptable = Utils.json_from_table_zb(vtable, "rows", True, False)
Set cswap = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}") Set cswap = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}")
cswap("scenario")("version") = handler.plan cswap("scenario")("version") = handler.plan
cswap("scenario")("iter") = handler.basis cswap("scenario")("iter") = handler.basis
@ -1358,12 +1354,3 @@ Function iter_def(ByVal iter As String) As String
iter_def = "exclude" iter_def = "exclude"
End Function 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 jsql As String
Public scenario As String Public scenario As String
Public sc() As Variant Public sc() As Variant
Public x As New TheBigOne
Public wapi As New Windows_API
Public data() As String Public data() As String
Public agg() As String Public agg() As String
Public showprice As Boolean Public showprice As Boolean
@ -21,8 +19,6 @@ Sub load_fpvt()
Application.StatusBar = "retrieving selection data....." 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 i As Long
Dim s_tot As Object Dim s_tot As Object
@ -78,7 +74,6 @@ End Function
Sub pg_main_workset(rep As String) Sub pg_main_workset(rep As String)
Dim req As New WinHttp.WinHttpRequest Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API
Dim wr As String Dim wr As String
Dim json As Object Dim json As Object
Dim i As Long Dim i As Long
@ -181,8 +176,8 @@ Sub pg_main_workset(rep As String)
ReDim str(UBound(res, 1), UBound(res, 2)) ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents shData.Cells.ClearContents
Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True) Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True)
End Sub 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") 'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
'doc = JsonConverter.ConvertToJson(doc) 'doc = JsonConverter.ConvertToJson(doc)
server = Sheets("config").Cells(1, 2) server = shConfig.Cells(1, 2)
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -311,16 +306,16 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
' Next i ' Next i
i = 1 i = 1
Do Until Sheets("data").Cells(i, 1) = "" Do Until shData.Cells(i, 1) = ""
i = i + 1 i = i + 1
Loop 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 End Function
@ -329,13 +324,13 @@ Sub load_config()
Dim i As Integer Dim i As Integer
Dim j As Integer Dim j As Integer
'----server to use--------------------------------------------------------- '----server to use---------------------------------------------------------
handler.server = Sheets("config").Cells(1, 2) handler.server = shConfig.Cells(1, 2)
'---basis----------------------------------------------------------------- '---basis-----------------------------------------------------------------
ReDim handler.basis(100) ReDim handler.basis(100)
i = 2 i = 2
j = 0 j = 0
Do While Sheets("config").Cells(2, i) <> "" Do While shConfig.Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i) handler.basis(j) = shConfig.Cells(2, i)
j = j + 1 j = j + 1
i = i + 1 i = i + 1
Loop Loop
@ -344,8 +339,8 @@ Sub load_config()
ReDim handler.baseline(100) ReDim handler.baseline(100)
i = 2 i = 2
j = 0 j = 0
Do While Sheets("config").Cells(3, i) <> "" Do While shConfig.Cells(3, i) <> ""
handler.baseline(j) = Sheets("config").Cells(3, i) handler.baseline(j) = shConfig.Cells(3, i)
j = j + 1 j = j + 1
i = i + 1 i = i + 1
Loop Loop
@ -354,14 +349,14 @@ Sub load_config()
ReDim handler.adjust(100) ReDim handler.adjust(100)
i = 2 i = 2
j = 0 j = 0
Do While Sheets("config").Cells(4, i) <> "" Do While shConfig.Cells(4, i) <> ""
handler.adjust(j) = Sheets("config").Cells(4, i) handler.adjust(j) = shConfig.Cells(4, i)
j = j + 1 j = j + 1
i = i + 1 i = i + 1
Loop Loop
ReDim Preserve handler.adjust(j - 1) ReDim Preserve handler.adjust(j - 1)
'---plan version-------------------------------------------------------------- '---plan version--------------------------------------------------------------
handler.plan = Sheets("config").Cells(9, 2) handler.plan = shConfig.Cells(9, 2)
End Sub End Sub
@ -370,104 +365,105 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
Dim j As Object Dim j As Object
Dim i As Integer Dim i As Integer
Dim r As Long Dim r As Long
Dim sh As Worksheet
Set sh = Sheets("_month")
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}") With shMonthUpdate
sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
For i = 0 To 12 Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
'------------volume------------------- .Cells(1, 16) = JsonConverter.ConvertToJson(j)
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)
'------------value---------------------- For i = 0 To 12
sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0) '------------volume-------------------
sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0) .Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0) .Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
sh.Cells(i + 1, 14) = 0 .Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
sh.Cells(i + 1, 15) = co_num(pkg(i, 8), 0) .Cells(i + 1, 4) = 0
.Cells(i + 1, 5) = co_num(pkg(i, 4), 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
'--base-- '------------value----------------------
If co_num(pkg(i, 2), 0) = 0 Then .Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
'if there is no monthly base volume, .Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
'then use the prior price, if there was no prior price, .Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
'then inherit the average price for the year before current adjustments .Cells(i + 1, 14) = 0
If sh.Cells(i, 7) <> 0 Then .Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
sh.Cells(i + 1, 7) = sh.Cells(i, 7)
'-------------price----------------------
If i > 0 Then
'--prior--
If co_num(pkg(i, 1), 0) = 0 Then
.Cells(i + 1, 6) = 0
Else Else
If pkg(13, 1) + pkg(13, 2) = 0 Then .Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1)
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
End If End If
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2) '--base--
End If If co_num(pkg(i, 2), 0) = 0 Then
'if there is no monthly base volume,
'--adjust-- 'then use the prior price, if there was no prior price,
If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then 'then inherit the average price for the year before current adjustments
sh.Cells(i + 1, 8) = 0 If .Cells(i, 7) <> 0 Then
Else .Cells(i + 1, 7) = .Cells(i, 7)
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)) Else
End If If pkg(13, 1) + pkg(13, 2) = 0 Then
.Cells(i + 1, 7) = 0
'--current adjust-- Else
sh.Cells(i + 1, 9) = 0 .Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
'--forecast-- End If
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)
Else Else
If pkg(13, 1) + pkg(13, 2) = 0 Then .Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
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
End If 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
End If Next i
Next i 'scenario
.Range("R1:S1000").ClearContents
'scenario For i = 0 To UBound(handler.sc, 1)
Sheets("_month").Range("R1:S1000").ClearContents .Cells(i + 1, 18) = handler.sc(i, 0)
For i = 0 To UBound(handler.sc, 1) .Cells(i + 1, 19) = handler.sc(i, 1)
sh.Cells(i + 1, 18) = handler.sc(i, 0) Next i
sh.Cells(i + 1, 19) = handler.sc(i, 1)
Next i 'basket
.Range("U1:AC100000").ClearContents
'basket Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True)
sh.Range("U1:AC100000").ClearContents Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True)
Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True) shConfig.Cells(5, 2) = 0
Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True) shConfig.Cells(6, 2) = 0
Sheets("config").Cells(5, 2) = 0 shConfig.Cells(7, 2) = 0
Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 2) = 0 shMonthView.load_sheet
months.load_sheet
End With
End Sub End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant 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 Exit Function
End If End If
server = Sheets("config").Cells(1, 2) server = shConfig.Cells(1, 2)
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .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") logid = json("x")(1)("id")
'---------loop through and get a list of each row that needs deleted?----- '---------loop through and get a list of each row that needs deleted?-----
Set ds = Sheets("data")
j = 0 j = 0
For i = 1 To 100 For i = 1 To 100
If ds.Cells(1, i) = "logid" Then If shData.Cells(1, i) = "logid" Then
j = i j = i
Exit For Exit For
End If End If
@ -577,15 +571,15 @@ Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant(
End If End If
i = 2 i = 2
While ds.Cells(i, 1) <> "" With shData
If ds.Cells(i, j) = logid Then While .Cells(i, 1) <> ""
ds.Rows(i).Delete If .Cells(i, j) = logid Then
Else .Rows(i).Delete
i = i + 1 Else
End If i = i + 1
Wend End If
Wend
End With
End Function End Function
@ -610,7 +604,7 @@ Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
Exit Function Exit Function
End If End If
server = Sheets("config").Cells(1, 2) server = shConfig.Cells(1, 2)
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All .Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All

14
VBA/openf.frm
View File

@ -25,7 +25,7 @@ Private Sub cbOK_Click()
openf.Caption = "retrieving data......" openf.Caption = "retrieving data......"
Call handler.pg_main_workset(cbDSM.value) Call handler.pg_main_workset(cbDSM.value)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh shOrders.PivotTables("ptOrders").PivotCache.Refresh
Application.StatusBar = False Application.StatusBar = False
openf.Hide openf.Hide
@ -34,18 +34,10 @@ 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 = Sheets("config").Cells(1, 2) handler.server = shConfig.Cells(1, 2)
Dim x As New TheBigOne
Dim d() As String
openf.Caption = "Select a DSM" openf.Caption = "Select a DSM"
d = x.SHTp_Get("reps", 1, 1, True) cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.value
For i = 1 To UBound(d, 2)
Call cbDSM.AddItem(d(0, i))
Next i
End Sub 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() Private Sub UserForm_Activate()
useval = False useval = False
cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.value
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
End Sub 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 BEGIN
MultiUse = -1 'True MultiUse = -1 'True
END END
Attribute VB_Name = "months" Attribute VB_Name = "shMonthView"
Attribute VB_GlobalNameSpace = False 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 x As New TheBigOne
Private units() As Variant Private units() As Variant
Private price() As Variant Private price() As Variant
Private sales() As Variant Private sales() As Variant
@ -31,13 +30,6 @@ Private b() As Variant 'holds basket
Private did_load_config As Boolean Private did_load_config As Boolean
Private Sub cbMTAG_Change()
End Sub
Private Sub sbMPP_Change() Private Sub sbMPP_Change()
Dim m As Worksheet Dim m As Worksheet
Dim i As Long Dim i As Long
@ -46,7 +38,7 @@ Private Sub sbMPP_Change()
dumping = True dumping = True
Set m = Sheets("month") Set m = shMonthView
m.Cells(19, 11) = sbMPP.value / 100 m.Cells(19, 11) = sbMPP.value / 100
For i = 6 To 17 For i = 6 To 17
m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11) m.Cells(i, 11) = (m.Cells(i, 9)) * m.Cells(19, 11)
@ -68,7 +60,7 @@ Private Sub sbMPV_Change()
dumping = True dumping = True
Set m = Sheets("month") Set m = shMonthView
m.Cells(19, 5) = sbMPV.value / 100 m.Cells(19, 5) = sbMPV.value / 100
For i = 6 To 17 For i = 6 To 17
If m.Cells(i, 5) <> "" Then 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("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("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 Set basket_touch = Target
Call Me.get_edit_basket Call Me.get_edit_basket
Set basket_touch = Nothing Set basket_touch = Nothing
@ -129,7 +121,7 @@ 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("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 Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
@ -140,7 +132,7 @@ End Sub
Sub picker_shortcut() 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) Call Me.basket_pick(Selection)
End If End If
@ -148,7 +140,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 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 Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
@ -228,7 +220,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 = Sheets("month").Range("Q2") vp = shMonthView.Range("Q2")
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
@ -284,7 +276,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 = Sheets("month").Range("Q2") vp = shMonthView.Range("Q2")
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
@ -344,7 +336,7 @@ Sub get_sheet()
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(Sheets("_month").Range("P1").FormulaR1C1) Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
End Sub End Sub
@ -361,15 +353,15 @@ Sub set_sheet()
Range("H18:L18").FormulaR1C1 = tprice Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales Range("N18:R18").FormulaR1C1 = tsales
Range("T6:U18").ClearContents Range("T6:U18").ClearContents
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), shMonthView.Name, 6, 20, False, False, False)
'Sheets("month").Range("B32:Q5000").ClearContents 'shMonthView.Range("B32:Q5000").ClearContents
If Me.newpart Then If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents shMonthUpdate.Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else Else
For i = 1 To 12 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 Next i
End If End If
@ -379,16 +371,16 @@ End Sub
Sub load_sheet() Sub load_sheet()
units = Sheets("_month").Range("A2:E13").FormulaR1C1 units = shMonthUpdate.Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1 price = shMonthUpdate.Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1 sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
scenario = Sheets("_month").Range("R1:S13").FormulaR1C1 scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1
tunits = Range("B18:F18") tunits = Range("B18:F18")
tprice = Range("H18:L18") tprice = Range("H18:L18")
tsales = Range("N18:R18") tsales = Range("N18:R18")
'reset basket 'reset basket
Sheets("_month").Range("U1:X10000").ClearContents shMonthUpdate.Range("U1:X10000").ClearContents
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False) Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False)
ReDim adjust(12) ReDim adjust(12)
Call Me.crunch_array Call Me.crunch_array
Call Me.set_sheet Call Me.set_sheet
@ -410,17 +402,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 = Sheets("month").Range("H6:L17") Set prices = shMonthView.Range("H6:L17")
Set price_adj = Sheets("month").Range("K6:K17") Set price_adj = shMonthView.Range("K6:K17")
Set price_set = Sheets("month").Range("L6:L17") Set price_set = shMonthView.Range("L6:L17")
Set vol = Sheets("month").Range("B6:F17") Set vol = shMonthView.Range("B6:F17")
Set vol_adj = Sheets("month").Range("E6:E17") Set vol_adj = shMonthView.Range("E6:E17")
Set vol_set = Sheets("month").Range("F6:F17") Set vol_set = shMonthView.Range("F6:F17")
Set val = Sheets("month").Range("N6:R17") Set val = shMonthView.Range("N6:R17")
Set val_adj = Sheets("month").Range("Q6:Q17") Set val_adj = shMonthView.Range("Q6:Q17")
Set val_set = Sheets("month").Range("R6:R17") Set val_set = shMonthView.Range("R6:R17")
Call Me.format_price(prices) Call Me.format_price(prices)
Call Me.set_border(prices) Call Me.set_border(prices)
@ -541,8 +533,8 @@ Sub build_json()
ReDim handler.basis(100) ReDim handler.basis(100)
i = 2 i = 2
j = 0 j = 0
Do While Sheets("config").Cells(2, i) <> "" Do While shConfig.Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i) handler.basis(j) = shConfig.Cells(2, i)
j = j + 1 j = j + 1
i = i + 1 i = i + 1
Loop Loop
@ -568,7 +560,7 @@ Sub build_json()
Set o = JsonConverter.ParseJson("{}") Set o = JsonConverter.ParseJson("{}")
o("amount") = sales(pos, 5) o("amount") = sales(pos, 5)
o("qty") = units(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 End If
Else Else
'if something is changing 'if something is changing
@ -585,7 +577,7 @@ Sub build_json()
'--ignore above comment and always use add month_vp '--ignore above comment and always use add month_vp
adjust(pos)("type") = "addmonth_vp" adjust(pos)("type") = "addmonth_vp"
End If 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)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4) adjust(pos)("amount") = sales(pos, 4)
Else Else
@ -603,7 +595,7 @@ Sub build_json()
adjust(pos)("qty") = units(pos, 4) adjust(pos)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4) adjust(pos)("amount") = sales(pos, 4)
'------------add this in to only scale a particular month-------------------- '------------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 End If
adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
adjust(pos)("user") = Application.UserName adjust(pos)("user") = Application.UserName
@ -616,24 +608,24 @@ Sub build_json()
If Me.newpart Then If Me.newpart Then
Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m)) 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) 'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet 'get the basket from the sheet
b = Worksheets("_month").Range("U1").CurrentRegion.value b = shMonthUpdate.Range("U1").CurrentRegion.value
Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False)) Set m = JsonConverter.ParseJson(Utils.json_from_table(b, "basket", False))
If UBound(b, 1) <= 2 Then 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 Else
Set np("basket") = m("basket") Set np("basket") = m("basket")
End If End If
End If End If
If Me.newpart Then If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents shMonthUpdate.Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np) shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else Else
For i = 1 To 12 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 Next i
End If End If
@ -689,12 +681,11 @@ End Sub
Sub Cancel() Sub Cancel()
Sheets("Orders").Select shOrders.Select
End Sub End Sub
Sub reset() Sub reset()
Call Me.load_sheet Call Me.load_sheet
@ -703,10 +694,10 @@ End Sub
Sub switch_basket() Sub switch_basket()
If Sheets("config").Cells(6, 2) = 1 Then If shConfig.Cells(6, 2) = 1 Then
Sheets("config").Cells(6, 2) = 0 shConfig.Cells(6, 2) = 0
Else Else
Sheets("config").Cells(6, 2) = 1 shConfig.Cells(6, 2) = 1
End If End If
Call Me.print_basket Call Me.print_basket
@ -716,10 +707,10 @@ End Sub
Sub print_basket() Sub print_basket()
'Sheets("config").Cells(6, 2) = 1 'SHCONFIG.Cells(6, 2) = 1
If Sheets("config").Cells(6, 2) = 0 Then If shConfig.Cells(6, 2) = 0 Then
dumping = True dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents shMonthView.Range("B32:Q10000").ClearContents
Rows("20:31").Hidden = False Rows("20:31").Hidden = False
dumping = False dumping = False
Exit Sub Exit Sub
@ -727,16 +718,16 @@ Sub print_basket()
Dim i As Long Dim i As Long
Dim basket() As Variant Dim basket() As Variant
basket = x.SHTp_get_block(Sheets("_month").Range("U1")) basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
dumping = True dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents shMonthView.Range("B32:Q10000").ClearContents
For i = 1 To UBound(basket, 1) For i = 1 To UBound(basket, 1)
Sheets("month").Cells(31 + i, 2) = basket(i, 1) shMonthView.Cells(31 + i, 2) = basket(i, 1)
Sheets("month").Cells(31 + i, 6) = basket(i, 2) shMonthView.Cells(31 + i, 6) = basket(i, 2)
Sheets("month").Cells(31 + i, 12) = basket(i, 3) shMonthView.Cells(31 + i, 12) = basket(i, 3)
Sheets("month").Cells(31 + i, 17) = basket(i, 4) shMonthView.Cells(31 + i, 17) = basket(i, 4)
Next i Next i
Rows("21:31").Hidden = True Rows("21:31").Hidden = True
@ -751,26 +742,26 @@ Sub basket_pick(ByRef Target As Range)
Dim i As Long Dim i As Long
build.part = Sheets("month").Cells(Target.row, 2) build.part = shMonthView.Cells(Target.row, 2)
build.bill = rev_cust(Sheets("month").Cells(Target.row, 6)) build.bill = rev_cust(shMonthView.Cells(Target.row, 6))
build.ship = rev_cust(Sheets("month").Cells(Target.row, 12)) build.ship = rev_cust(shMonthView.Cells(Target.row, 12))
build.useval = False build.useval = False
build.Show build.Show
If build.useval Then If build.useval Then
dumping = True dumping = True
'if an empty row is selected, force it to be the next open slot 'if an empty row is selected, force it to be the next open slot
If Sheets("month").Cells(Target.row, 2) = "" Then If shMonthView.Cells(Target.row, 2) = "" Then
Do Until Sheets("month").Cells(Target.row + i, 2) <> "" Do Until shMonthView.Cells(Target.row + i, 2) <> ""
i = i - 1 i = i - 1
Loop Loop
i = i + 1 i = i + 1
End If End If
Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value shMonthView.Cells(Target.row + i, 2) = build.cbPart.value
Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value) shMonthView.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, 12) = rev_cust(build.cbShip.value)
dumping = False dumping = False
Set basket_touch = Selection Set basket_touch = Selection
Call Me.get_edit_basket Call Me.get_edit_basket
@ -793,7 +784,7 @@ Sub get_edit_basket()
'ReDim b(basket_rows, 3) 'ReDim b(basket_rows, 3)
i = 0 i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = "" Do Until shMonthView.Cells(33 + i, 2) = ""
i = i + 1 i = i + 1
Loop Loop
i = i - 1 i = i - 1
@ -804,14 +795,14 @@ Sub get_edit_basket()
i = 0 i = 0
mix = 0 mix = 0
Do Until Worksheets("month").Cells(33 + i, 2) = "" Do Until shMonthView.Cells(33 + i, 2) = ""
b(i, 0) = Worksheets("month").Cells(33 + i, 2) b(i, 0) = shMonthView.Cells(33 + i, 2)
b(i, 1) = Worksheets("month").Cells(33 + i, 6) b(i, 1) = shMonthView.Cells(33 + i, 6)
b(i, 2) = Worksheets("month").Cells(33 + i, 12) b(i, 2) = shMonthView.Cells(33 + i, 12)
b(i, 3) = Worksheets("month").Cells(33 + i, 17) b(i, 3) = shMonthView.Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0 If b(i, 3) = "" Then b(i, 3) = 0
mix = mix + b(i, 3) 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_mix = touch_mix + b(i, 3)
touch(i) = True touch(i) = True
untouched = untouched - 1 untouched = untouched - 1
@ -834,13 +825,13 @@ Sub get_edit_basket()
'put the mix plug back on the the sheet 'put the mix plug back on the the sheet
For i = 0 To UBound(b, 1) 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 Next i
dumping = False dumping = False
Worksheets("_month").Range("U2:X5000").ClearContents shMonthUpdate.Range("U2:X5000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True)
If Me.newpart Then If Me.newpart Then
Me.build_json Me.build_json
@ -860,7 +851,7 @@ Sub post_adjust()
Dim jdoc As String Dim jdoc As String
If Me.newpart Then 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("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
@ -868,8 +859,8 @@ Sub post_adjust()
If fail Then Exit Sub If fail Then Exit Sub
Else Else
For i = 2 To 13 For i = 2 To 13
If Sheets("_month").Cells(i, 16) <> "" Then If shMonthUpdate.Cells(i, 16) <> "" Then
Set adjust = JsonConverter.ParseJson(Sheets("_month").Cells(i, 16)) Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16))
adjust("message") = Me.tbMCOM.text adjust("message") = Me.tbMCOM.text
adjust("tag") = Me.cbMTAG.text adjust("tag") = Me.cbMTAG.text
jdoc = JsonConverter.ConvertToJson(adjust) jdoc = JsonConverter.ConvertToJson(adjust)
@ -879,14 +870,14 @@ Sub post_adjust()
Next i Next i
End If End If
Sheets("Orders").Select shOrders.Select
'Worksheets("month").Visible = xlHidden 'shMonthView.Visible = xlHidden
End Sub End Sub
Sub build_new() Sub build_new()
Worksheets("config").Cells(5, 2) = 1 shConfig.Cells(5, 2) = 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
@ -894,7 +885,7 @@ Sub build_new()
dumping = True dumping = True
m = Sheets("_month").Range("A2:O13").FormulaR1C1 m = shMonthUpdate.Range("A2:O13").FormulaR1C1
For i = 1 To UBound(m, 1) For i = 1 To UBound(m, 1)
For j = 1 To UBound(m, 2) For j = 1 To UBound(m, 2)
@ -902,20 +893,18 @@ Sub build_new()
Next j Next j
Next i Next i
Worksheets("_month").Range("A2:O13") = m shMonthUpdate.Range("A2:O13") = m
Worksheets("_month").Range("U2:X1000").ClearContents shMonthUpdate.Range("U2:X1000").ClearContents
Worksheets("_month").Range("Z2:AC1000").ClearContents shMonthUpdate.Range("Z2:AC1000").ClearContents
Worksheets("_month").Range("R2:S1000").ClearContents shMonthUpdate.Range("R2:S1000").ClearContents
Call Me.load_sheet 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")) basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
Sheets("month").Cells(32, 2) = basket(1, 1) shMonthView.Cells(32, 2) = basket(1, 1)
Sheets("month").Cells(32, 6) = basket(1, 2) shMonthView.Cells(32, 6) = basket(1, 2)
Sheets("month").Cells(32, 12) = basket(1, 3) shMonthView.Cells(32, 12) = basket(1, 3)
Sheets("month").Cells(32, 17) = basket(1, 4) shMonthView.Cells(32, 17) = basket(1, 4)
Call Me.print_basket Call Me.print_basket
dumping = False dumping = False
@ -934,8 +923,8 @@ Sub new_part()
'---------build customer mix------------------------------------------------------------------- '---------build customer mix-------------------------------------------------------------------
cust = x.SHTp_Get("_month", 1, 27, True) cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True)
If Not x.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then
MsgBox ("error building customer mix") MsgBox ("error building customer mix")
End If End If
@ -949,49 +938,49 @@ Sub new_part()
dumping = True dumping = True
Worksheets("month").Range("B33:Q10000").ClearContents shMonthView.Range("B33:Q10000").ClearContents
For i = 1 To UBound(cust, 2) For i = 1 To UBound(cust, 2)
Sheets("month").Cells(32 + i, 2) = part.cbPart.value shMonthView.Cells(32 + i, 2) = part.cbPart.value
Sheets("month").Cells(32 + i, 6) = cust(0, i) shMonthView.Cells(32 + i, 6) = cust(0, i)
Sheets("month").Cells(32 + i, 12) = cust(1, i) shMonthView.Cells(32 + i, 12) = cust(1, i)
Sheets("month").Cells(32 + i, 17) = CDbl(cust(2, i)) shMonthView.Cells(32 + i, 17) = CDbl(cust(2, i))
Next i Next i
Sheets("config").Cells(7, 2) = 1 shConfig.Cells(7, 2) = 1
'------copy revised basket to _month storage--------------------------------------------------- '------copy revised basket to _month storage---------------------------------------------------
i = 0 i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = "" Do Until shMonthView.Cells(33 + i, 2) = ""
i = i + 1 i = i + 1
Loop Loop
i = i - 1 i = i - 1
If i = -1 Then i = 0 If i = -1 Then i = 0
ReDim b(i, 3) ReDim b(i, 3)
i = 0 i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = "" Do Until shMonthView.Cells(33 + i, 2) = ""
b(i, 0) = Worksheets("month").Cells(33 + i, 2) b(i, 0) = shMonthView.Cells(33 + i, 2)
b(i, 1) = Worksheets("month").Cells(33 + i, 6) b(i, 1) = shMonthView.Cells(33 + i, 6)
b(i, 2) = Worksheets("month").Cells(33 + i, 12) b(i, 2) = shMonthView.Cells(33 + i, 12)
b(i, 3) = Worksheets("month").Cells(33 + i, 17) b(i, 3) = shMonthView.Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0 If b(i, 3) = "" Then b(i, 3) = 0
i = i + 1 i = i + 1
Loop Loop
Worksheets("_month").Range("U2:AC10000").ClearContents shMonthUpdate.Range("U2:AC10000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) Call Utils.SHTp_DumpVar(b, shMonthUpdate.Name, 2, 21, False, False, True)
Call x.SHTp_DumpVar(b, "_month", 2, 26, 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------------------------------------ '------reset volume to copy base to forecsat and clear base------------------------------------
units = Sheets("_month").Range("A2:E13").FormulaR1C1 units = shMonthUpdate.Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1 price = shMonthUpdate.Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1 sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
tunits = Range("B18:F18") tunits = Range("B18:F18")
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(Sheets("_month").Range("P1").FormulaR1C1) 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)
@ -1018,13 +1007,13 @@ Sub new_part()
'-------------push revised arrays back to _month, not revertable------------------------------- '-------------push revised arrays back to _month, not revertable-------------------------------
Worksheets("_month").Range("A2:E13") = units shMonthUpdate.Range("A2:E13") = units
Worksheets("_month").Range("F2:J13") = price shMonthUpdate.Range("F2:J13") = price
Worksheets("_month").Range("K2:o13") = sales shMonthUpdate.Range("K2:o13") = sales
'force basket to show to demonstrate the part was changed '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 Call Me.print_basket
dumping = False dumping = False
@ -1032,7 +1021,7 @@ End Sub
Function newpart() As Boolean Function newpart() As Boolean
If Worksheets("config").Cells(7, 2) = 1 Then If shConfig.Cells(7, 2) = 1 Then
newpart = True newpart = True
Else Else
newpart = False newpart = False

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

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