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

Compare commits

base: pt:0ae9f604c1baf1ff477108bc5d9586c6ec81559c
Branches Tags
pt:dev
pt:master
pt:v1.6.2
pt:v1.6.1
pt:v1.6
pt:v1.5
pt:v1.3
pt:v1.2
pt:v1.0
pt:v0.9
pt:v0.8
pt:v0.6
pt:v0.5
pt:v0.4
pt:v0.3
pt:v0.2
pt:v0.1
..
compare: pt:8809cb9ad4a76b1aabe24551b7248f4319dcecb7
Branches Tags
pt:dev
pt:master
pt:v1.6.2
pt:v1.6.1
pt:v1.6
pt:v1.5
pt:v1.3
pt:v1.2
pt:v1.0
pt:v0.9
pt:v0.8
pt:v0.6
pt:v0.5
pt:v0.4
pt:v0.3
pt:v0.2
pt:v0.1

No commits in common. "0ae9f604c1baf1ff477108bc5d9586c6ec81559c" and "8809cb9ad4a76b1aabe24551b7248f4319dcecb7" have entirely different histories.
0ae9f604c1 ... 8809cb9ad4

23 changed files with 91 additions and 8475 deletions
Show Stats Expand all files Collapse all files

BIN
Master Template.xlsm
View File

Binary file not shown.

1125
VBA/JsonConverter.bas
View File

File diff suppressed because it is too large Load Diff

43
VBA/JsonDebugPrint.bas
View File

@ -1,43 +0,0 @@
Attribute VB_Name = "JsonDebugPrint"
Option Explicit
Public Sub TestPrintJSON()
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
' tool to make sense of the objects that come out of JsonConverter.ParseJSON.
' It doesn't format in the best way possible, but it does provide a semi-readable
' view of the data in the JSON object.
' Phil Runninger 3/1/2023
'
Public Sub PrintJSON(obj As Variant, Optional level As Integer = 0)
Dim itm As Variant
Dim first As Boolean
Select Case TypeName(obj)
Case "Dictionary"
Debug.Print String(level * 2, " "); "{"
first = True
For Each itm In obj
If Not first Then Debug.Print String((level + 1) * 2, " "); ","
first = False
Debug.Print String((level + 1) * 2, " "); itm; ":";
PrintJSON obj(itm), level + 1
Next
Debug.Print String(level * 2, " "); "}"
Case "Collection"
Debug.Print String(level * 2, " "); "["
first = True
For Each itm In obj
If Not first Then Debug.Print String(level * 2, " "); ","
first = False
PrintJSON itm, level + 1
Next
Debug.Print String(level * 2, " "); "]"
Case Else
Debug.Print String(level * 2, " "); obj;
End Select
End Sub

2730
VBA/TheBigOne.cls
View File

File diff suppressed because it is too large Load Diff

618
VBA/Utils.bas
View File

@ -1,618 +0,0 @@
Attribute VB_Name = "Utils"
Option Explicit
Public ADOo_errstring As String
Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, ByRef headers As Boolean, ByRef del_unused As Boolean, ParamArray groupnum_type_sumnum()) As Boolean
Dim i As Long
Dim j As Long
Dim nt() As String
Dim keep() As Integer
If needsort Then
If Not TBLp_BubbleSortAsc(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
End If
If Not TBLp_Roll(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
If del_unused Then
keep = PAp_2DGetMultIntegerArray(ARRAYp_MakeInteger(0, 2), groupnum_type_sumnum)
ReDim nt(UBound(keep()), UBound(tbl, 2))
For i = 0 To UBound(keep())
For j = 0 To UBound(tbl, 2)
nt(i, j) = tbl(keep(i), j)
Next j
Next i
tbl = nt
End If
TBLp_Aggregate = True
End Function
Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean
On Error GoTo errh
'get fort field numbers
'loop through each row and generate the row key
'eveluate the row key against other row keys
'perform swaps
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
If headers Then k = 1
For i = k To UBound(tbl, 2) - 1
For j = i + 1 To UBound(tbl, 2)
If ROWe_AscSwapFlag(tbl, i, j, sortflds, typeflds) Then
Call ROWp_Swap(tbl, i, j)
Else
If ADOo_errstring <> "" Then
TBLp_BubbleSortAsc = False
Exit Function
End If
End If
Next j
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description)
ADOo_errstring = Err.Description
End If
TBLp_BubbleSortAsc = True
End Function
Public Function TBLp_Roll(ByRef tbl() As String, ByRef gflds() As Integer, ByRef sflds() As Integer, ByRef headers As Boolean) As Boolean
On Error GoTo errh
Dim i As Long 'indexes primary row
Dim j As Long 'indexes secondary chaecker row
Dim k As Integer 'used to start at 0 or 1
Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1
k = 0
If headers Then k = 1
m = k
For i = k To UBound(tbl, 2)
If i = UBound(tbl, 2) Then
i = i
End If
j = i + 1
Do
If j > UBound(tbl, 2) Then Exit Do
If ROWe_MatchesFlag(tbl, i, j, gflds) Then
Call ROWp_Aggregate2Rows(tbl, i, j, sflds)
Else
Exit Do
End If
j = j + 1
If j > UBound(tbl, 2) Then
Exit Do
End If
Loop
Call ROWp_Copy(tbl, i, m)
m = m + 1
i = j - 1
Next i
ReDim Preserve tbl(UBound(tbl, 1), m - 1)
errh:
If Err.Number <> 0 Then
ADOo_errstring = Err.Description
TBLp_Roll = False
Exit Function
End If
TBLp_Roll = True
End Function
Sub ROWp_Swap(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long)
Dim temprow() As String
ReDim temprow(UBound(tbl, 1))
Dim i As Integer
For i = 0 To UBound(tbl, 1)
temprow(i) = tbl(i, p2)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p2) = tbl(i, p1)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p1) = temprow(i)
Next i
End Sub
Sub ROWp_Copy(ByRef tbl() As String, ByRef r_from As Long, ByRef r_to As Long)
Dim i As Integer
For i = 0 To UBound(tbl, 1)
tbl(i, r_to) = tbl(i, r_from)
Next i
End Sub
Sub ROWp_Aggregate2Rows(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long, ByRef sflds() As Integer)
Dim i As Integer
On Error GoTo exitsub
For i = 0 To UBound(sflds, 1)
tbl(sflds(i), p1) = CDbl(tbl(sflds(i), p1)) + CDbl(tbl(sflds(i), p2))
Next i
exitsub:
End Sub
Function ROWe_AscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean
'only returns true if greater than
On Error GoTo errh
Dim i As Integer
Dim compare As Integer
For i = 0 To UBound(KeyFld)
Select Case TypeFld(i)
Case "S"
compare = MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2)))
Case "N"
compare = MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2)))
Case "D"
compare = MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2)))
End Select
Select Case compare
Case -1
ROWe_AscSwapFlag = True
Exit Function
Case 1
ROWe_AscSwapFlag = False
Exit Function
End Select
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description)
ADOo_errstring = Err.Description
Exit Function
End If
End Function
Function ROWe_MatchesFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean
'only returns true if greater than
Dim i As Integer
Dim k1 As String
Dim k2 As String
For i = 0 To UBound(KeyFld())
k1 = k1 & tbl(KeyFld(i), row1)
Next i
For i = 0 To UBound(KeyFld())
k2 = k2 & tbl(KeyFld(i), row2)
Next i
If k2 = k1 Then
ROWe_MatchesFlag = True
Else
ROWe_MatchesFlag = False
End If
End Function
Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ByRef zerobase As Boolean)
Dim sh As Worksheet
Dim address As String
Set sh = Sheets(sheet)
'If clear Then sh.Cells.clear
'If transpose Then Call ARRAYp_Transpose(tbl)
If zerobase Then
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address
Else
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1) - 1, col + UBound(tbl, 2) - 1).address
End If
sh.Range(address).FormulaR1C1 = tbl
On Error GoTo errhndl
errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
End Sub
Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant()
Dim s() As Variant
ReDim s(UBound(a, 2), UBound(a, 1))
Dim i As Long
Dim j As Long
For i = 0 To UBound(s, 1)
For j = 0 To UBound(s, 2)
s(i, j) = a(j, i)
Next j
Next i
ARRAYp_TransposeVar = s
End Function
Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant()
Dim i As Long
Dim j As Long
Dim r() As Variant
ReDim r(UBound(z, 1), UBound(z, 2) + 1)
For i = 0 To UBound(r, 1)
For j = 1 To UBound(r, 2)
r(i, j) = z(i, j - 1)
Next j
r(i, 0) = cols(i)
Next i
ARRAYp_zerobased_addheader = r
End Function
Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String()
Dim i As Long
Dim j As Long
Dim table() As String
Dim sh As Worksheet
Set sh = Sheets(sheet)
On Error GoTo errhdnl
i = 1
While sh.Cells(row, col + i - 1) <> ""
i = i + 1
Wend
j = 1
While sh.Cells(row + j - 1, col) <> ""
j = j + 1
Wend
ReDim table(i - 2, j - 2)
i = 1
While i <= UBound(table, 1) + 1
j = 0
While j <= UBound(table, 2)
table(i - 1, j) = sh.Cells(row + j, col + i - 1)
j = j + 1
Wend
i = i + 1
Wend
errhdnl:
If Err.Number <> 0 Then
MsgBox (Err.Description)
End If
SHTp_Get = table
End Function
Function PAp_2DGetStringArray(ByRef index As Integer, ParamArray pa()) As String()
Dim str() As String
Dim i As Long
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
PAp_2DGetStringArray = str
End Function
Function PAp_2DGetIntegerArray(ByRef index As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
If UBound(pa(0)(index)) <> -1 Then
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
End If
PAp_2DGetIntegerArray = str
End Function
Function PAp_2DGetMultIntegerArray(ByRef ArraysGet() As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim index As Long
'get length of selected arrays
For i = 0 To UBound(ArraysGet, 1)
cnt = cnt + UBound(pa(0)(ArraysGet(i)))
Next i
ReDim str(cnt + 1)
cnt = 0
For i = 0 To UBound(ArraysGet, 1)
For j = 0 To UBound(pa(0)(ArraysGet(i)))
str(cnt) = pa(0)(ArraysGet(i))(j)
cnt = cnt + 1
Next j
Next i
PAp_2DGetMultIntegerArray = str
End Function
Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer()
Dim x() As Integer
Dim i As Integer
ReDim x(UBound(items))
For i = 0 To UBound(items())
x(i) = items(i)
Next i
ARRAYp_MakeInteger = x
End Function
Public Function MISCe_CompareString(ByRef base As String, ByRef compare As String) As Integer
If compare < base Then
MISCe_CompareString = -1
Exit Function
End If
If compare = base Then
MISCe_CompareString = 0
Exit Function
End If
If compare > base Then
MISCe_CompareString = 1
Exit Function
End If
End Function
Public Function MISCe_CompareDouble(ByRef base As Double, ByRef compare As Double) As Integer
If compare < base Then
MISCe_CompareDouble = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDouble = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDouble = 1
Exit Function
End If
End Function
Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As Integer
If compare < base Then
MISCe_CompareDate = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDate = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDate = 1
Exit Function
End If
End Function
Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 2 To UBound(tbl, 1)
For c = 1 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(1, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 2 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
If r > 3 Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table = ajson
End Function
Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, ByVal force_array As Boolean, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 1 To UBound(tbl, 1)
For c = 0 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 1 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
If r > 2 Or force_array Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table_zb = ajson
End Function
Public Function SHTp_get_block(point As Range) As Variant()
SHTp_get_block = point.CurrentRegion
End Function
Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
Dim i As Long
hdr.ColumnCount = det.ColumnCount
hdr.ColumnWidths = det.ColumnWidths
' add header elements
hdr.clear
hdr.AddItem
For i = 0 To UBound(cols, 1)
hdr.list(0, i) = cols(i)
Next i
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
hdr.SpecialEffect = fmSpecialEffectFlat
'hdr.BackColor = RGB(200, 200, 200)
hdr.Height = 10
' align header to body (should be done last!)
hdr.width = det.width
hdr.Left = det.Left
hdr.Top = det.Top - (hdr.Height - 1)
End Sub

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

81
VBA/build.frm
View File

@ -1,81 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build
Caption = "UserForm1"
ClientHeight = 3015
ClientLeft = 120
ClientTop = 465
ClientWidth = 8100
OleObjectBlob = "build.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "build"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public part As String
Public bill As String
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
useval = True
Me.Hide
Case 27
useval = False
Me.Hide
End Select
End Sub
Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
useval = True
Me.Hide
Case 27
useval = False
Me.Hide
End Select
End Sub
Private Sub cbShip_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
useval = True
Me.Hide
Case 27
useval = False
Me.Hide
End Select
End Sub
Private Sub UserForm_Activate()
useval = False
cbPart.value = part
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
End Sub

BIN
VBA/build.frx
View File

Binary file not shown.

134
VBA/changes.frm
View File

@ -1,134 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes
Caption = "History"
ClientHeight = 7785
ClientLeft = 120
ClientTop = 465
ClientWidth = 16710
OleObjectBlob = "changes.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "changes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private x As Variant
Private Sub cbCancel_Click()
Me.Hide
End Sub
Private Sub cbUndo_Click()
Call Me.delete_selected
End Sub
Private Sub lbHist_Change()
Dim i As Integer
For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then
Me.tbPrint.value = x(i, 7)
Exit Sub
End If
Next i
End Sub
Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 46
Call Me.delete_selected
Case 27
Call Me.Hide
End Select
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)
If fail Then
Me.Hide
Exit Sub
End If
Me.lbHist.list = x
lbHEAD.ColumnCount = lbHist.ColumnCount
lbHEAD.ColumnWidths = lbHist.ColumnWidths
' add header elements
lbHEAD.clear
lbHEAD.AddItem
lbHEAD.list(0, 0) = "Modifier"
lbHEAD.list(0, 1) = "Owner"
lbHEAD.list(0, 2) = "When"
lbHEAD.list(0, 3) = "Tag"
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")
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
'lbHEAD.SpecialEffect = fmSpecialEffectFlat
'lbHEAD.BackColor = RGB(200, 200, 200)
'lbHEAD.Height = 10
' align header to body (should be done last!)
'lbHEAD.width = lbHist.width
'lbHEAD.Left = lbHist.Left
'lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1)
End Sub
Sub delete_selected()
Dim logid As Integer
Dim i As Integer
Dim fail As Boolean
Dim proceed As Boolean
If MsgBox("Permanently delete these changes?", vbOKCancel) = vbCancel Then
Exit Sub
End If
For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then
Call handler.undo_changes(x(i, 6), fail)
If fail Then
MsgBox ("undo did not work")
Exit Sub
End If
End If
Next i
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
Me.lbHist.clear
Me.Hide
End Sub

BIN
VBA/changes.frx
View File

Binary file not shown.

1368
VBA/fpvt.frm
View File

File diff suppressed because it is too large Load Diff

BIN
VBA/fpvt.frx
View File

Binary file not shown.

643
VBA/handler.bas
View File

@ -1,643 +0,0 @@
Attribute VB_Name = "handler"
Option Explicit
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
Public server As String
Public plan As String
Public basis() As Variant
Public baseline() As Variant
Public adjust() As Variant
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
fpvt.lbSDET.list = handler.sc
showprice = False
For i = 0 To UBound(handler.sc, 1)
If handler.sc(i, 0) = "part_descr" Then
showprice = True
Exit For
End If
Next i
fpvt.Show
End Sub
Function scenario_package(doc As String, ByRef status As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
On Error GoTo errh
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/scenario_package", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
Set scenario_package = json
errh:
If Err.Number <> 0 Then
status = False
MsgBox (Err.Description)
Set scenario_package = Nothing
Else
status = True
End If
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
Dim j As Long
Dim doc As String
Dim res() As Variant
Dim str() As String
doc = "{""quota_rep"":""" & rep & """}"
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", handler.server & "/get_pool", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
If Mid(wr, 1, 1) <> "{" Then
MsgBox (wr)
Exit Sub
End If
Set json = JsonConverter.ParseJson(wr)
ReDim res(json("x").Count, 33)
For i = 1 To UBound(res, 1)
res(i, 0) = json("x")(i)("bill_cust_descr")
res(i, 1) = json("x")(i)("billto_group")
res(i, 2) = json("x")(i)("ship_cust_descr")
res(i, 3) = json("x")(i)("shipto_group")
res(i, 4) = json("x")(i)("quota_rep_descr")
res(i, 5) = json("x")(i)("director")
res(i, 6) = json("x")(i)("segm")
res(i, 7) = json("x")(i)("substance")
res(i, 8) = json("x")(i)("chan")
res(i, 9) = json("x")(i)("chansub")
res(i, 10) = json("x")(i)("part_descr")
res(i, 11) = json("x")(i)("part_group")
res(i, 12) = json("x")(i)("branding")
res(i, 13) = json("x")(i)("majg_descr")
res(i, 14) = json("x")(i)("ming_descr")
res(i, 15) = json("x")(i)("majs_descr")
res(i, 16) = json("x")(i)("mins_descr")
res(i, 17) = json("x")(i)("order_season")
res(i, 18) = json("x")(i)("order_month")
res(i, 19) = json("x")(i)("ship_season")
res(i, 20) = json("x")(i)("ship_month")
res(i, 21) = json("x")(i)("request_season")
res(i, 22) = json("x")(i)("request_month")
res(i, 23) = json("x")(i)("promo")
res(i, 24) = json("x")(i)("value_loc")
res(i, 25) = json("x")(i)("value_usd")
res(i, 26) = json("x")(i)("cost_loc")
res(i, 27) = json("x")(i)("cost_usd")
res(i, 28) = json("x")(i)("units")
res(i, 29) = json("x")(i)("version")
res(i, 30) = json("x")(i)("iter")
res(i, 31) = json("x")(i)("logid")
res(i, 32) = json("x")(i)("tag")
res(i, 33) = json("x")(i)("comment")
Next i
res(0, 0) = "bill_cust_descr"
res(0, 1) = "billto_group"
res(0, 2) = "ship_cust_descr"
res(0, 3) = "shipto_group"
res(0, 4) = "quota_rep_descr"
res(0, 5) = "director"
res(0, 6) = "segm"
res(0, 7) = "substance"
res(0, 8) = "chan"
res(0, 9) = "chansub"
res(0, 10) = "part_descr"
res(0, 11) = "part_group"
res(0, 12) = "branding"
res(0, 13) = "majg_descr"
res(0, 14) = "ming_descr"
res(0, 15) = "majs_descr"
res(0, 16) = "mins_descr"
res(0, 17) = "order_season"
res(0, 18) = "order_month"
res(0, 19) = "ship_season"
res(0, 20) = "ship_month"
res(0, 21) = "request_season"
res(0, 22) = "request_month"
res(0, 23) = "promo"
res(0, 24) = "value_loc"
res(0, 25) = "value_usd"
res(0, 26) = "cost_loc"
res(0, 27) = "cost_usd"
res(0, 28) = "units"
res(0, 29) = "version"
res(0, 30) = "iter"
res(0, 31) = "logid"
res(0, 32) = "tag"
res(0, 33) = "comment"
Set json = Nothing
ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents
Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
End Sub
Sub pull_rep()
openf.Show
End Sub
Function request_adjust(doc As String, ByRef fail As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Long
Dim j As Long
Dim str() As String
If doc = "" Then
fail = True
Exit Function
End If
'update timestamp
Set json = JsonConverter.ParseJson(doc)
'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
'doc = JsonConverter.ConvertToJson(doc)
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "POST", server & "/" & json("type"), True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
If Mid(wr, 2, 5) = "error" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<body>" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<!DOCT" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "null" Then
MsgBox ("API route not implemented")
fail = True
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no adjustment was made")
fail = False
Exit Function
End If
ReDim res(json("x").Count - 1, 33)
For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("bill_cust_descr")
res(i, 1) = json("x")(i + 1)("billto_group")
res(i, 2) = json("x")(i + 1)("ship_cust_descr")
res(i, 3) = json("x")(i + 1)("shipto_group")
res(i, 4) = json("x")(i + 1)("quota_rep_descr")
res(i, 5) = json("x")(i + 1)("director")
res(i, 6) = json("x")(i + 1)("segm")
res(i, 7) = json("x")(i + 1)("substance")
res(i, 8) = json("x")(i + 1)("chan")
res(i, 9) = json("x")(i + 1)("chansub")
res(i, 10) = json("x")(i + 1)("part_descr")
res(i, 11) = json("x")(i + 1)("part_group")
res(i, 12) = json("x")(i + 1)("branding")
res(i, 13) = json("x")(i + 1)("majg_descr")
res(i, 14) = json("x")(i + 1)("ming_descr")
res(i, 15) = json("x")(i + 1)("majs_descr")
res(i, 16) = json("x")(i + 1)("mins_descr")
res(i, 17) = json("x")(i + 1)("order_season")
res(i, 18) = json("x")(i + 1)("order_month")
res(i, 19) = json("x")(i + 1)("ship_season")
res(i, 20) = json("x")(i + 1)("ship_month")
res(i, 21) = json("x")(i + 1)("request_season")
res(i, 22) = json("x")(i + 1)("request_month")
res(i, 23) = json("x")(i + 1)("promo")
res(i, 24) = json("x")(i + 1)("value_loc")
res(i, 25) = json("x")(i + 1)("value_usd")
res(i, 26) = json("x")(i + 1)("cost_loc")
res(i, 27) = json("x")(i + 1)("cost_usd")
res(i, 28) = json("x")(i + 1)("units")
res(i, 29) = json("x")(i + 1)("version")
res(i, 30) = json("x")(i + 1)("iter")
res(i, 31) = json("x")(i + 1)("logid")
res(i, 32) = json("x")(i + 1)("tag")
res(i, 33) = json("x")(i + 1)("comment")
Next i
Set json = Nothing
ReDim str(UBound(res, 1), UBound(res, 2))
' For i = 0 To UBound(res, 1)
' For j = 0 To UBound(res, 2)
' If IsNull(res(i, j)) Then
' str(i, j) = ""
' Else
' str(i, j) = res(i, j)
' End If
' Next j
' Next i
i = 1
Do Until Sheets("data").Cells(i, 1) = ""
i = i + 1
Loop
Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
End Function
Sub load_config()
Dim i As Integer
Dim j As Integer
'----server to use---------------------------------------------------------
handler.server = Sheets("config").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)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
'---baseline-----------------------------------------------------------------
ReDim handler.baseline(100)
i = 2
j = 0
Do While Sheets("config").Cells(3, i) <> ""
handler.baseline(j) = Sheets("config").Cells(3, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.baseline(j - 1)
'---adjustments-----------------------------------------------------------------
ReDim handler.adjust(100)
i = 2
j = 0
Do While Sheets("config").Cells(4, i) <> ""
handler.adjust(j) = Sheets("config").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)
End Sub
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)
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)
'------------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
'--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)
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
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)
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
End If
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
End If
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
End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
If one = "" Or IsNull(one) Then
co_num = two
Else
co_num = one
End If
End Function
Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/list_changes", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no history")
fail = True
Exit Function
End If
ReDim res(json("x").Count - 1, 7)
For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("user")
res(i, 1) = json("x")(i + 1)("quota_rep_descr")
res(i, 2) = json("x")(i + 1)("stamp")
res(i, 3) = json("x")(i + 1)("tag")
res(i, 4) = json("x")(i + 1)("comment")
res(i, 5) = json("x")(i + 1)("sales")
res(i, 6) = json("x")(i + 1)("id")
res(i, 7) = json("x")(i + 1)("doc")
Next i
list_changes = res
End Function
Function undo_changes(ByVal logid As Integer, ByRef fail As Boolean) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim res() As Variant
Dim doc As String
Dim ds As Worksheet
doc = "{""logid"":" & logid & "}"
server = handler.server
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/undo_change", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
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
j = i
Exit For
End If
Next i
If j = 0 Then
MsgBox ("current data set is not tracking changes, cannot isolate change locally")
fail = True
Exit Function
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
End Function
Sub history()
changes.Show
End Sub
Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/swap_fit", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no history")
fail = True
Exit Function
End If
ReDim res(json("x").Count - 1, 3)
For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("part")
res(i, 1) = json("x")(i + 1)("value_usd")
res(i, 2) = json("x")(i + 1)("swap")
res(i, 3) = json("x")(i + 1)("fit")
Next i
get_swap_fit = res
End Function

1043
VBA/months.cls
View File

File diff suppressed because it is too large Load Diff

51
VBA/openf.frm
View File

@ -1,51 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf
Caption = "Open a Forecast"
ClientHeight = 2025
ClientLeft = 120
ClientTop = 465
ClientWidth = 3825
OleObjectBlob = "openf.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "openf"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cbCancel_Click()
openf.Hide
End Sub
Private Sub cbOK_Click()
Application.StatusBar = "Retrieving data for " & cbDSM.value & "....."
openf.Caption = "retrieving data......"
Call handler.pg_main_workset(cbDSM.value)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
Application.StatusBar = False
openf.Hide
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
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
End Sub

BIN
VBA/openf.frx
View File

Binary file not shown.

48
VBA/part.frm
View File

@ -1,48 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part
Caption = "Part Picker"
ClientHeight = 1080
ClientLeft = 120
ClientTop = 465
ClientWidth = 8100
OleObjectBlob = "part.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "part"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public part As String
Public bill As String
Public ship As String
Public useval As Boolean
Option Explicit
Private Sub cbPart_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
useval = True
Me.Hide
Case 27
useval = False
Me.Hide
End Select
End Sub
Private Sub UserForm_Activate()
useval = False
cbPart.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
End Sub

BIN
VBA/part.frx
View File

Binary file not shown.

122
VBA/pivot.cls
View File

@ -1,122 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot"
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
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
Cancel = True
Dim i As Long
Dim j As Long
Dim k As Long
Dim ri As PivotItemList
Dim ci As PivotItemList
Dim df As Object
Dim rd As Object
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
Set df = Target.Cells.PivotCell.DataField
Set rd = Target.Cells.PivotTable.RowFields
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
For i = 1 To ri.Count
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name
Next i
scenario = "{" & handler.jsql & "}"
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub
Function piv_pos(list As Object, target_pos As Long) As Long
Dim i As Long
For i = 1 To list.Count
If list(i).Position = target_pos Then
piv_pos = i
Exit Function
End If
Next i
'should not get to this point
End Function
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
Dim i As Integer
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i).Name = field_name Then
piv_fld_index = i
Exit Function
End If
Next i
End Function
Function escape_json(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", "\""")
If text = "(blank)" Then text = ""
escape_json = text
End Function
Function escape_sql(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", """""")
If text = "(blank)" Then text = ""
escape_sql = text
End Function

122
VBA/pivot1.cls
View File

@ -1,122 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot1"
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
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
Cancel = True
Dim i As Long
Dim j As Long
Dim k As Long
Dim ri As PivotItemList
Dim ci As PivotItemList
Dim df As Object
Dim rd As Object
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
Set df = Target.Cells.PivotCell.DataField
Set rd = Target.Cells.PivotTable.RowFields
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
For i = 1 To ri.Count
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name
Next i
scenario = "{" & handler.jsql & "}"
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub
Function piv_pos(list As Object, target_pos As Long) As Long
Dim i As Long
For i = 1 To list.Count
If list(i).Position = target_pos Then
piv_pos = i
Exit Function
End If
Next i
'should not get to this point
End Function
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
Dim i As Integer
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i).Name = field_name Then
piv_fld_index = i
Exit Function
End If
Next i
End Function
Function escape_json(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", "\""")
If text = "(blank)" Then text = ""
escape_json = text
End Function
Function escape_sql(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", """""")
If text = "(blank)" Then text = ""
escape_sql = text
End Function

62
build/build_forecast.sql
View File

@ -1,18 +1,33 @@
-- Connection: usmidsap01.ubm -- Connection: usmidsap01.ubm
--\timing --\timing
/*----------------------------------------------------------------------------------------
1. copy existing actuals for the current season (which is incomplete)
* for example 6/1/22 -> 3/7/23
2. fill out a full year of history by going back 2 years to get 3/8/22 -> 5/31/22
3. stack the results of 1 & 2 and increment all rows by 1 year
*/----------------------------------------------------------------------------------------
TRUNCATE TABLE rlarp.osmf; TRUNCATE TABLE rlarp.osmf;
INSERT INTO rlarp.osmf INSERT INTO rlarp.osmf
WITH WITH
baseline AS ( gld AS (
SELECT
N1COMP COMP
,N1CCYY FSYR
,KPMAXP PERDS
,N1FSPP PERD
,to_char(N1FSYP,'FM0000') FSPR
,N1SD01 SDAT
,N1ED01 EDAT
,to_char(N1ED01,'yymm') CAPR
,N1ED01 - N1SD01 +1 NDAYS
,CASE WHEN EXTRACT(MONTH FROM N1ED01) >= 6 THEN EXTRACT(YEAR FROM N1ED01) + 1 ELSE EXTRACT(YEAR FROM N1ED01) END SSYR
,to_char(CASE WHEN EXTRACT(MONTH FROM N1ED01) >= 6 THEN EXTRACT(MONTH FROM N1ED01) -5 ELSE EXTRACT(MONTH FROM N1ED01) +7 END,'00') SSPR
FROM
LGDAT.GLDATREF
INNER JOIN LGDAT.GLDATE ON
KPCOMP = N1COMP AND
KPCCYY = N1CCYY
WHERE
N1COMP = 93
--AND DIGITS(N1FSYP) = '1901'
)
--SELECT * FROM gld
,baseline AS (
SELECT SELECT
-----------documents------------- -----------documents-------------
null::int "ddord#" null::int "ddord#"
@ -122,15 +137,15 @@ baseline AS (
-----when null, greatest/least is just going to act like coalesce -----when null, greatest/least is just going to act like coalesce
,greatest(least(o.sdate,gld.edat),gld.sdat) sdate ,greatest(least(o.sdate,gld.edat),gld.sdat) sdate
,ss.ssyr sseas ,ss.ssyr sseas
,'b23' "version" ,'15mo' "version"
,'actuals' iter ,'actuals' iter
FROM FROM
rlarp.osm o rlarp.osm o
--snap the ship dates of the historic fiscal period --snap the ship dates of the historic fiscal period
LEFT OUTER JOIN rlarp.gld ON LEFT OUTER JOIN gld ON
gld.fspr = o.fspr gld.fspr = o.fspr
--get the shipping season for open orders based on the snapped date --get the shipping season for open orders based on the snapped date
LEFT OUTER JOIN rlarp.gld ss ON LEFT OUTER JOIN gld ss ON
greatest(least(o.sdate,gld.edat),gld.sdat) BETWEEN ss.sdat AND ss.edat greatest(least(o.sdate,gld.edat),gld.sdat) BETWEEN ss.sdat AND ss.edat
WHERE WHERE
( (
@ -280,23 +295,19 @@ baseline AS (
-----when null, greatest/least is just going to act like coalesce -----when null, greatest/least is just going to act like coalesce
,greatest(least(o.sdate,gld.edat),gld.sdat) + interval '1 year' sdate ,greatest(least(o.sdate,gld.edat),gld.sdat) + interval '1 year' sdate
,ss.ssyr sseas ,ss.ssyr sseas
,'b23' "version" ,'actuals' "version"
,'actuals_plug' iter ,'actuals_plug' iter
FROM FROM
rlarp.osm o rlarp.osm o
LEFT OUTER JOIN rlarp.gld ON LEFT OUTER JOIN gld ON
gld.fspr = o.fspr gld.fspr = o.fspr
LEFT OUTER JOIN rlarp.gld ss ON LEFT OUTER JOIN gld ss ON
greatest(least(o.sdate,gld.edat),gld.sdat) + interval '1 year' BETWEEN ss.sdat AND ss.edat greatest(least(o.sdate,gld.edat),gld.sdat) + interval '1 year' BETWEEN ss.sdat AND ss.edat
WHERE WHERE
o.odate BETWEEN '2022-03-01' AND '2022-05-31' o.odate BETWEEN '2022-03-01' AND '2022-05-31'
AND fs_line = '41010' AND fs_line = '41010'
AND calc_status <> 'CANCELED' AND calc_status <> 'CANCELED'
AND NOT (calc_status = 'CLOSED' AND flag = 'REMAINDER') ------exclude actuals for now and use forecast to get the plug for the rest of the year
--OR (
-- (o.fspr BETWEEN '2209' AND '2212' OR o.fspr = '0000')
-- AND o.sdate BETWEEN '2022-03-01' AND '2022-05-31'
--)
AND version = 'ACTUALS' AND version = 'ACTUALS'
GROUP BY GROUP BY
o.fspr o.fspr
@ -432,13 +443,13 @@ baseline AS (
-----when null, greatest/least is just going to act like coalesce -----when null, greatest/least is just going to act like coalesce
,greatest(least(o.sdate,gld.edat),gld.sdat) sdate ,greatest(least(o.sdate,gld.edat),gld.sdat) sdate
,ss.ssyr sseas ,ss.ssyr sseas
,'b23' "version" ,'actuals' "version"
,'forecast_plug' iter ,'forecast_plug' iter
FROM FROM
rlarp.osmp o rlarp.osmp o
LEFT OUTER JOIN rlarp.gld ON LEFT OUTER JOIN gld ON
gld.fspr = o.fspr gld.fspr = o.fspr
LEFT OUTER JOIN rlarp.gld ss ON LEFT OUTER JOIN gld ss ON
greatest(least(o.sdate,gld.edat),gld.sdat) BETWEEN ss.sdat AND ss.edat greatest(least(o.sdate,gld.edat),gld.sdat) BETWEEN ss.sdat AND ss.edat
WHERE WHERE
false false
@ -468,7 +479,6 @@ baseline AS (
,greatest(least(o.sdate,gld.edat),gld.sdat) ,greatest(least(o.sdate,gld.edat),gld.sdat)
,ss.ssyr ,ss.ssyr
) )
----------increment the baseline selection---------------------
,incr AS ( ,incr AS (
SELECT SELECT
o."ddord#" o."ddord#"
@ -579,8 +589,8 @@ SELECT
,'copy' iter ,'copy' iter
FROM FROM
baseline o baseline o
LEFT OUTER JOIN rlarp.gld ON LEFT OUTER JOIN gld ON
(o.sdate + interval '1 year') BETWEEN gld.sdat and gld.edat o.sdate + interval '1 year' BETWEEN gld.sdat and gld.edat
WHERE WHERE
o.odate + interval '1 year' >= '2023-06-01' o.odate + interval '1 year' >= '2023-06-01'
) )

105
build/convert_pool_all.sql
View File

@ -3,12 +3,11 @@ LANGUAGE plpgsql AS
$func$ $func$
BEGIN BEGIN
DELETE FROM rlarp.osmfs; DELETE FROM rlarp.osmfs_dev;
INSERT INTO INSERT INTO
rlarp.osmfs rlarp.osmfs_dev
SELECT SELECT
------------document ids---------------------
null::int4, null::int4,
null::int4, null::int4,
null::int4, null::int4,
@ -17,17 +16,14 @@ SELECT
null::int4, null::int4,
null::int4, null::int4,
null::int4, null::int4,
------------document dates-------------------
order_date, order_date,
request_date, request_date,
null::date, null::date,
null::date, null::date,
ship_date, ship_date,
------------document flags-------------------
null::text, null::text,
null::text, null::text,
fspr, fspr,
------------document quantities--------------
null::numeric, null::numeric,
null::numeric, null::numeric,
null::numeric, null::numeric,
@ -35,7 +31,6 @@ SELECT
null::numeric, null::numeric,
null::numeric, null::numeric,
null::jsonb, null::jsonb,
------------document attributes--------------
null::text, null::text,
plnt, plnt,
promo, promo,
@ -43,7 +38,6 @@ SELECT
terms, terms,
null::text, null::text,
null::text, null::text,
------------customer info---------------------
null::text, null::text,
rtrim(substring(bill_cust_descr,1,8)), rtrim(substring(bill_cust_descr,1,8)),
null::text, null::text,
@ -67,7 +61,6 @@ SELECT
null::text, null::text,
null::text, null::text,
null::text, null::text,
------------product info----------------------
part, part,
null::text, null::text,
null::text, null::text,
@ -91,10 +84,8 @@ SELECT
null::text, null::text,
null::text, null::text,
null::text, null::text,
null::text,
null::numeric, null::numeric,
null::numeric, null::numeric,
------------fiscal info-----------------------
null::text, null::text,
fs_line, fs_line,
r_currency, r_currency,
@ -110,15 +101,12 @@ SELECT
cost_loc, cost_loc,
null::numeric, null::numeric,
null::numeric, null::numeric,
------------status info-----------------------
calc_status, calc_status,
flag, flag,
order_date, order_date,
order_season, order_season,
request_date, request_date,
request_season, request_season,
null::date promise_date,
null::int promise_season,
ship_date, ship_date,
ship_season, ship_season,
version, version,
@ -127,38 +115,37 @@ SELECT
FROM FROM
rlarp.osm_pool rlarp.osm_pool
WHERE WHERE
version <> 'actuals'; version <> 'actuals'
-------need to set item master values before other things----------- -------need to set item master values before other things-----------
UPDATE UPDATE
RLARP.osmfs O RLARP.OSMFS_DEV O
SET SET
stlc = m.stlc STYC = M.STLC
,colc = m.colc ,COLC = M.COLC
,colgrp = m.colgrp ,COLGRP = M.COLGRP
,coltier = m.coltier ,COLTIER = M.COLTIER
,colstat = m.colstat ,COLSTAT = M.COLSTAT
,sizc = m.sizc ,SIZC = M.SIZC
,uomp = m.uomp ,PCKG = M.PACKAGE
,suffix = m.suffix ,KIT = M.KIT
,accs_ps = m.accs_ps ,BRND = M.BRANDING
,brnd = m.branding ,MAJG = M.MAJG
,majg = m.majg ,MING = M.MING
,ming = m.ming ,MAJS = M.MAJS
,majs = m.majs ,MINS = M.MINS
,mins = m.mins ,GLDC = M.GLCD
,gldc = m.glcd ,GLEC = M.GLEC
,glec = m.glec ,HARM = M.HARM
,harm = m.harm ,CLSS = M.CLSS
,clss = m.clss ,BRAND = M.BRAND
,brand = m.brand ,ASSC = M.ASSC
,assc = m.assc ,LBS = CASE M.NWUN WHEN 'KG' THEN 2.2046 ELSE 1 END*M.NWHT
,lbs = CASE m.nwun WHEN 'kg' THEN 2.2046 ELSE 1 END*m.nwht ,UNTI = M.UNTI
,unti = m.unti
FROM FROM
"CMS.CUSLG".itemm m RLARP.ITEMM M
WHERE WHERE
m.item = o.part; M.ITEM = O.PART;
WITH WITH
@ -167,7 +154,7 @@ plist AS (
part part
,plnt ,plnt
FROM FROM
rlarp.osmfs rlarp.osmfS_dev
) )
,clist AS ( ,clist AS (
SELECT SELECT
@ -187,7 +174,7 @@ plist AS (
AND ir.y0plnt = p.plnt AND ir.y0plnt = p.plnt
) )
UPDATE UPDATE
rlarp.osmfs o rlarp.osmfs_dev o
SET SET
fb_cst_loc_cur = c.stdcost * o.fb_qty fb_cst_loc_cur = c.stdcost * o.fb_qty
FROM FROM
@ -199,7 +186,7 @@ WHERE
----------------------------SET BILL-TO REP------------------------------------ ----------------------------SET BILL-TO REP------------------------------------
UPDATE UPDATE
RLARP.osmfs S RLARP.OSMFS_DEV S
SET SET
BILL_REP = C.BVSALM BILL_REP = C.BVSALM
,BILL_CLASS = C.BVCLAS ,BILL_CLASS = C.BVCLAS
@ -226,7 +213,7 @@ WHERE
----------------------------SET SHIP-TO REP------------------------------------ ----------------------------SET SHIP-TO REP------------------------------------
UPDATE UPDATE
RLARP.osmfs S RLARP.OSMFS_DEV S
SET SET
SHIP_REP = C.BVSALM SHIP_REP = C.BVSALM
,SHIP_CLASS = C.BVCLAS ,SHIP_CLASS = C.BVCLAS
@ -239,18 +226,18 @@ FROM
WHERE WHERE
C.BVCUST = S.SHIP_CUST C.BVCUST = S.SHIP_CUST
AND ( AND (
COALESCE(s.ship_rep,'') <> c.bvsalm COALESCE(S.SHIP_REP,'') <> C.BVSALM
OR COALESCE(s.ship_class,'') <> c.bvclas OR COALESCE(S.SHIP_CLASS,'') <> C.BVCLAS
OR COALESCE(s.ship_terr,'') <> c.bvterr OR COALESCE(S.SHIP_TERR,'') <> C.BVTERR
OR COALESCE(dest_ctry,'') <> c.bvctry OR COALESCE(dest_CTRY,'') <> C.bvctry
OR COALESCE(dest_prov,'') <> c.bvprcd OR COALESCE(dest_prov,'') <> C.bvprcd
OR COALESCE(dest_post,'') <> c.bvpost OR COALESCE(dest_post,'') <> C.bvpost
); );
----------------------------SET BILLTO GROUP------------------------------------ ----------------------------SET BILLTO GROUP------------------------------------
UPDATE UPDATE
RLARP.osmfs O RLARP.OSMFS_DEV O
SET SET
ACCOUNT = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END ACCOUNT = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END
FROM FROM
@ -264,7 +251,7 @@ WHERE
----------------------------SET SHIPTO GROUP------------------------------------ ----------------------------SET SHIPTO GROUP------------------------------------
UPDATE UPDATE
RLARP.osmfs O RLARP.OSMFS_DEV O
SET SET
SHIPGRP = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END SHIPGRP = CASE BVADR6 WHEN '' THEN BVNAME ELSE BVADR6 END
FROM FROM
@ -278,7 +265,7 @@ WHERE
UPDATE UPDATE
rlarp.osmfs rlarp.osmFS_dev
SET SET
CHAN = CASE SUBSTRING(BILL_CLASS,2,3) CHAN = CASE SUBSTRING(BILL_CLASS,2,3)
--if the bill to class is ditsributor, then it's either warehouse or drop --if the bill to class is ditsributor, then it's either warehouse or drop
@ -334,7 +321,7 @@ WHERE
UPDATE UPDATE
RLARP.osmfs S RLARP.OSMFS_DEV S
SET SET
DSM = CR.QUOTA_REP DSM = CR.QUOTA_REP
FROM FROM
@ -362,8 +349,8 @@ FROM
END QUOTA_REP END QUOTA_REP
FROM FROM
RLARP.osmfs S RLARP.OSMFS_DEV S
LEFT OUTER JOIN lgdat.cust ON LEFT OUTER JOIN LGDAT.CUST ON
BVCUST = BILL_CUST BVCUST = BILL_CUST
LEFT OUTER JOIN lgpgm.usrcust cu ON LEFT OUTER JOIN lgpgm.usrcust cu ON
cu.cucust = s.bill_cust cu.cucust = s.bill_cust
@ -371,7 +358,7 @@ FROM
COALESCE(GLEC,'') IS NOT NULL COALESCE(GLEC,'') IS NOT NULL
) CR ) CR
WHERE WHERE
CR.VERSION = S.VERSION CR.VERSION = S.VERSION
AND CR.GLEC = COALESCE(S.GLEC,'') AND CR.GLEC = COALESCE(S.GLEC,'')
AND CR.MING = COALESCE(S.MING,'') AND CR.MING = COALESCE(S.MING,'')
AND CR.BILL_CUST = S.BILL_CUST AND CR.BILL_CUST = S.BILL_CUST
@ -382,7 +369,7 @@ WHERE
-------------------set fiscal period-------------------------------------- -------------------set fiscal period--------------------------------------
UPDATE UPDATE
rlarp.osmfs f rlarp.osmfs_dev f
SET SET
fspr = gld.fspr fspr = gld.fspr
FROM FROM
@ -443,7 +430,7 @@ WHERE
--DELETE FROM rlarp.osmf_dev WHERE iter IN ('adj price','adj volume'); --DELETE FROM rlarp.osmf_dev WHERE iter IN ('adj price','adj volume');
--INSERT INTO rlarp.osmf_dev SELECT * FROM rlarp.osmf; --INSERT INTO rlarp.osmf_dev SELECT * FROM rlarp.osmfs_dev;
COMMIT; COMMIT;
END END

24
inquirey/osmf_months.sql
View File

@ -1,21 +1,15 @@
SELECT SELECT
--o.glec
to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon') order_month to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon') order_month
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND iter = 'actuals'),0) act2023 ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'plan'),0) plan2021
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND iter = 'actuals_plug'),0) act2023_plug ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'plan'),0) plan2022
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2023 AND version IN ('actuals','15mo')),0) total_baseline ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'diff'),0) diff2021
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2024 AND version = 'b23'),0) plan2024 ,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'diff'),0) diff2022
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2021 AND iter = 'actuals'),0) act2021
,ROUND(SUM(fb_val_loc * r_rate) FILTER (WHERE oseas = 2022 AND iter = 'actuals'),0) act2022
FROM FROM
rlarp.osmf o rlarp.osmfs_dev o
WHERE WHERE
oseas IN (2023,2024) oseas IN (2021,2022)
AND substring(glec,1,1) <= '2'
--AND quota_rep_descr = 'COLIN MAXWELL' --AND quota_rep_descr = 'COLIN MAXWELL'
GROUP BY GROUP BY
ROLLUP ( to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon')
--o.glec,
to_char(CASE WHEN extract(month FROM o.odate) >= 6 THEN -5 ELSE 7 END + extract(month FROM o.odate),'FM00')||' - '||to_char(o.odate,'TMMon')
)
ORDER BY
--o.glec,
order_month