Save the exported VBA code in the repo. This is its initial commit.
This commit is contained in:
PhilRunninger
parent
f8f1433546
commit
337f5425e2
1125
Master Template.xlsm_EXPORTS/JsonConverter.bas
Normal file
1125
Master Template.xlsm_EXPORTS/JsonConverter.bas
Normal file
File diff suppressed because it is too large
Load Diff
43
Master Template.xlsm_EXPORTS/JsonDebugPrint.bas
Normal file
43
Master Template.xlsm_EXPORTS/JsonDebugPrint.bas
Normal file
@ -0,0 +1,43 @@
|
||||
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
|
||||
|
||||
9
Master Template.xlsm_EXPORTS/ThisWorkbook.cls
Normal file
9
Master Template.xlsm_EXPORTS/ThisWorkbook.cls
Normal 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
|
||||
620
Master Template.xlsm_EXPORTS/Utils.bas
Normal file
620
Master Template.xlsm_EXPORTS/Utils.bas
Normal file
@ -0,0 +1,620 @@
|
||||
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 = 15
|
||||
|
||||
' align header to body (should be done last!)
|
||||
hdr.width = det.width
|
||||
hdr.Left = det.Left
|
||||
hdr.Top = det.Top - (hdr.Height + 3)
|
||||
|
||||
End Sub
|
||||
|
||||
Public Function IntersectsWith(Range1 As Range, Range2 As Range) As Boolean
|
||||
IntersectsWith = Not Application.Intersect(Range1, Range2) Is Nothing
|
||||
End Function
|
||||
|
||||
|
||||
39
Master Template.xlsm_EXPORTS/build.frm
Normal file
39
Master Template.xlsm_EXPORTS/build.frm
Normal file
@ -0,0 +1,39 @@
|
||||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} build
|
||||
Caption = "Change the Mix"
|
||||
ClientHeight = 1590
|
||||
ClientLeft = 120
|
||||
ClientTop = 465
|
||||
ClientWidth = 10725
|
||||
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
|
||||
Option Explicit
|
||||
|
||||
Public useval As Boolean
|
||||
|
||||
Private Sub cmdCancel_Click()
|
||||
useval = False
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub cmdOK_Click()
|
||||
useval = True
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Public Sub Initialize(part As String, billTo As String, shipTo As String)
|
||||
cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.Value
|
||||
cbPart.Value = part
|
||||
cbBill.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.Value
|
||||
cbBill.Value = billTo
|
||||
cbShip.list = shSupportingData.ListObjects("CUSTOMER").DataBodyRange.Value
|
||||
cbShip.Value = shipTo
|
||||
|
||||
useval = False
|
||||
End Sub
|
||||
BIN
Master Template.xlsm_EXPORTS/build.frx
Normal file
BIN
Master Template.xlsm_EXPORTS/build.frx
Normal file
Binary file not shown.
75
Master Template.xlsm_EXPORTS/changes.frm
Normal file
75
Master Template.xlsm_EXPORTS/changes.frm
Normal file
@ -0,0 +1,75 @@
|
||||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes
|
||||
Caption = "History"
|
||||
ClientHeight = 7815
|
||||
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 UserForm_Activate()
|
||||
tbPrint.Value = ""
|
||||
|
||||
Dim fail As Boolean
|
||||
X = handler.list_changes("{""scenario"":{""quota_rep_descr"":""" & shData.Cells(2, 5) & """}}", fail)
|
||||
If fail Then
|
||||
Unload Me
|
||||
MsgBox ("No adjustments have been made.")
|
||||
End
|
||||
End If
|
||||
Me.lbHist.list = X
|
||||
Call Utils.frmListBoxHeader(Me.lbHEAD, Me.lbHist, "Modifier", "Owner", "When", "Tag", "Comment", "Sales", "id")
|
||||
End Sub
|
||||
|
||||
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
|
||||
|
||||
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?", vbYesNo) = vbNo 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
|
||||
|
||||
shOrders.PivotTables("ptOrders").PivotCache.Refresh
|
||||
|
||||
Me.lbHist.clear
|
||||
Me.Hide
|
||||
End Sub
|
||||
BIN
Master Template.xlsm_EXPORTS/changes.frx
Normal file
BIN
Master Template.xlsm_EXPORTS/changes.frx
Normal file
Binary file not shown.
559
Master Template.xlsm_EXPORTS/fpvt.frm
Normal file
559
Master Template.xlsm_EXPORTS/fpvt.frm
Normal file
@ -0,0 +1,559 @@
|
||||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
|
||||
Caption = "Forecast Adjustment"
|
||||
ClientHeight = 8490.001
|
||||
ClientLeft = 120
|
||||
ClientTop = 465
|
||||
ClientWidth = 8670.001
|
||||
OleObjectBlob = "fpvt.frx":0000
|
||||
StartUpPosition = 1 'CenterOwner
|
||||
End
|
||||
Attribute VB_Name = "fpvt"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = False
|
||||
Option Explicit
|
||||
|
||||
Private month() As Variant
|
||||
Private adjust As Object
|
||||
Private load_tb As Boolean
|
||||
Private set_Price As Boolean
|
||||
Private sp As Object
|
||||
|
||||
Private bVol As Double
|
||||
Private bVal As Double
|
||||
Private bPrc As Double
|
||||
Private pVol As Double
|
||||
Private pVal As Double
|
||||
Private pPrc As Double
|
||||
Private aVol As Double
|
||||
Private aVal As Double
|
||||
Private aPrc As Double
|
||||
Private fVol As Double
|
||||
Private fVal As Double
|
||||
Private fPrc As Double
|
||||
|
||||
'=====================================================================================================
|
||||
' Developers' backdoor to enter or exit debug mode: Ctrl-RightClick on the "Selected Scenario"
|
||||
' label at the top of the form. Debug Mode shows the Pending Changes tab in the form, as well
|
||||
' as all hidden sheets.
|
||||
Private Sub Label62_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
|
||||
If Button = 2 And Shift = 2 Then
|
||||
shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode")
|
||||
mp.Pages("pAPIDOC").Visible = shConfig.Range("debug_mode")
|
||||
End If
|
||||
End Sub
|
||||
'=====================================================================================================
|
||||
|
||||
Private Sub butAdjust_Click()
|
||||
Dim fail As Boolean
|
||||
Dim msg As String
|
||||
|
||||
If tbAPI.text = "" Then msg = "No adjustments provided."
|
||||
If cbTAG.text = "" Then msg = "No tag was selected."
|
||||
If tbAPI.text = "" Then msg = "No adjustements are ready."
|
||||
|
||||
If msg <> "" Then
|
||||
MsgBox msg, vbOKOnly Or vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
If Not handler.request_adjust(tbAPI.text, msg) Then
|
||||
MsgBox msg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error."
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Me.tbCOM = ""
|
||||
Me.cbTAG.text = ""
|
||||
|
||||
Me.Hide
|
||||
|
||||
Set adjust = Nothing
|
||||
End Sub
|
||||
|
||||
Private Sub butCancel_Click()
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub cbGoSheet_Click()
|
||||
shMonthView.Range("MonthComment").Value = ""
|
||||
shMonthView.Range("MonthTag").Value = ""
|
||||
shMonthView.Range("QtyPctChange").Value = 0
|
||||
shMonthView.Range("PricePctChange").Value = 0
|
||||
shMonthView.Visible = xlSheetVisible
|
||||
shMonthView.Select
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub cbTAG_Change()
|
||||
Dim j As Object
|
||||
If tbAPI.text = "" Then tbAPI.text = "{}"
|
||||
Set j = JsonConverter.ParseJson(tbAPI.text)
|
||||
j("tag") = cbTAG.Value
|
||||
tbAPI.text = JsonConverter.ConvertToJson(j)
|
||||
End Sub
|
||||
|
||||
Private Sub opEditPrice_Click()
|
||||
opPlugVol.Visible = False
|
||||
opPlugPrice.Visible = False
|
||||
' opPlugPrice.Value = True
|
||||
' opPlugVol.Value = False
|
||||
|
||||
tbFcPrice.Enabled = True
|
||||
tbFcPrice.BackColor = &H80000018
|
||||
tbFcVal.Enabled = False
|
||||
tbFcVal.BackColor = &H80000005
|
||||
tbFcVol.Enabled = True
|
||||
tbFcVol.BackColor = &H80000018
|
||||
|
||||
sbpv.Enabled = True
|
||||
sbpp.Enabled = True
|
||||
sbpd.Enabled = False
|
||||
tbpv.Enabled = True
|
||||
tbpp.Enabled = True
|
||||
tbpd.Enabled = False
|
||||
End Sub
|
||||
|
||||
Private Sub opEditSales_Click()
|
||||
opPlugVol.Visible = True
|
||||
opPlugPrice.Visible = True
|
||||
|
||||
tbFcPrice.Enabled = False
|
||||
tbFcPrice.BackColor = &H80000005
|
||||
tbFcVal.Enabled = True
|
||||
tbFcVal.BackColor = &H80000018
|
||||
tbFcVol.Enabled = False
|
||||
tbFcVol.BackColor = &H80000005
|
||||
|
||||
sbpv.Enabled = False
|
||||
sbpp.Enabled = False
|
||||
sbpd.Enabled = True
|
||||
tbpv.Enabled = False
|
||||
tbpp.Enabled = False
|
||||
tbpd.Enabled = True
|
||||
End Sub
|
||||
|
||||
Private Sub opPlugPrice_Click()
|
||||
calc_val
|
||||
End Sub
|
||||
|
||||
Private Sub opPlugVol_Click()
|
||||
calc_val
|
||||
End Sub
|
||||
|
||||
Private Sub sbpd_Change()
|
||||
tbpd.Value = sbpd.Value
|
||||
End Sub
|
||||
|
||||
Private Sub sbpp_Change()
|
||||
tbpp.Value = sbpp.Value
|
||||
End Sub
|
||||
|
||||
Private Sub sbpv_Change()
|
||||
tbpv.Value = sbpv.Value
|
||||
End Sub
|
||||
|
||||
Private Sub tbCOM_Change()
|
||||
If tbAPI.text = "" Then tbAPI.text = "{}"
|
||||
Set adjust = JsonConverter.ParseJson(tbAPI.text)
|
||||
adjust("message") = tbCOM.text
|
||||
tbAPI.text = JsonConverter.ConvertToJson(adjust)
|
||||
End Sub
|
||||
|
||||
Private Sub tbFcPrice_Change()
|
||||
If load_tb Then Exit Sub
|
||||
set_Price = True
|
||||
If opEditPrice Then calc_price
|
||||
set_Price = False
|
||||
End Sub
|
||||
|
||||
Private Sub tbFcVal_Change()
|
||||
If load_tb Then Exit Sub
|
||||
If opEditSales Then calc_val
|
||||
End Sub
|
||||
|
||||
Private Sub tbFcVol_Change()
|
||||
If load_tb Then Exit Sub
|
||||
If opEditPrice Then calc_price
|
||||
End Sub
|
||||
|
||||
Private Sub tbpd_Change()
|
||||
If load_tb Then Exit Sub
|
||||
If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub
|
||||
tbFcVal = (bVal + pVal) * (1 + tbpd.Value / 100)
|
||||
End Sub
|
||||
|
||||
Private Sub tbpp_Change()
|
||||
If load_tb Then Exit Sub
|
||||
If Not VBA.IsNumeric(tbpd.Value) Then Exit Sub
|
||||
tbFcPrice = (bPrc + pPrc) * (1 + tbpp.Value / 100)
|
||||
Me.load_mbox_ann
|
||||
End Sub
|
||||
|
||||
Private Sub tbpv_Change()
|
||||
If load_tb Then Exit Sub
|
||||
If Not VBA.IsNumeric(tbpv.Value) Then Exit Sub
|
||||
tbFcVol = (bVol + pVol) * (1 + tbpv.Value / 100)
|
||||
End Sub
|
||||
|
||||
Private Sub UserForm_Activate()
|
||||
Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value & " Loading..."
|
||||
Me.mp.Visible = False
|
||||
Me.fraExit.Visible = False
|
||||
|
||||
Dim ok As Boolean
|
||||
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
|
||||
Call Utils.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
|
||||
|
||||
Me.Caption = "Forecast Adjust " & shConfig.Range("version").Value
|
||||
|
||||
If Not ok Then
|
||||
fpvt.Hide
|
||||
Application.StatusBar = False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
'---show existing adjustment if there is one----
|
||||
pVol = 0
|
||||
pVal = 0
|
||||
pPrc = 0
|
||||
bVol = 0
|
||||
bVal = 0
|
||||
bPrc = 0
|
||||
aVol = 0
|
||||
aVal = 0
|
||||
aPrc = 0
|
||||
fVal = 0
|
||||
fVol = 0
|
||||
fPrc = 0
|
||||
Me.tbAPI.Value = ""
|
||||
|
||||
If IsNull(sp("package")("totals")) Then
|
||||
MsgBox "An unexpected error has occurred when retrieving the scenario.", vbOKOnly Or vbExclamation, "Error"
|
||||
fpvt.Hide
|
||||
Application.StatusBar = False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim i As Long
|
||||
For i = 1 To sp("package")("totals").Count
|
||||
Select Case sp("package")("totals")(i)("order_season")
|
||||
Case 2025
|
||||
Select Case Me.iter_def(sp("package")("totals")(i)("iter"))
|
||||
Case "baseline"
|
||||
bVol = bVol + sp("package")("totals")(i)("units")
|
||||
bVal = bVal + sp("package")("totals")(i)("value_usd")
|
||||
If bVol <> 0 Then bPrc = bVal / bVol
|
||||
|
||||
Case "adjust"
|
||||
pVol = pVol + sp("package")("totals")(i)("units")
|
||||
pVal = pVal + sp("package")("totals")(i)("value_usd")
|
||||
|
||||
Case "exclude"
|
||||
|
||||
End Select
|
||||
End Select
|
||||
Next i
|
||||
|
||||
fVol = bVol + pVol
|
||||
fVal = bVal + pVal
|
||||
If fVol = 0 Then
|
||||
fPrc = 0
|
||||
Else
|
||||
fPrc = fVal / fVol
|
||||
End If
|
||||
If (bVol + pVol) = 0 Then
|
||||
pPrc = 0
|
||||
Else
|
||||
If bVol = 0 Then
|
||||
pPrc = 0
|
||||
Else
|
||||
pPrc = (pVal + bVal) / (bVol + pVol) - bVal / bVol
|
||||
End If
|
||||
End If
|
||||
If aVal <> 0 Then
|
||||
MsgBox (aVal)
|
||||
End If
|
||||
Me.load_mbox_ann
|
||||
|
||||
'---------------------------------------populate monthly-------------------------------------------------------
|
||||
|
||||
'--parse json into variant array for loading--
|
||||
ReDim month(sp("package")("mpvt").Count + 1, 10)
|
||||
|
||||
For i = 1 To sp("package")("mpvt").Count
|
||||
month(i, 0) = sp("package")("mpvt")(i)("order_month")
|
||||
month(i, 1) = sp("package")("mpvt")(i)("2024 qty")
|
||||
month(i, 2) = sp("package")("mpvt")(i)("2025 base qty")
|
||||
month(i, 3) = sp("package")("mpvt")(i)("2025 adj qty")
|
||||
month(i, 4) = sp("package")("mpvt")(i)("2025 tot qty")
|
||||
month(i, 5) = sp("package")("mpvt")(i)("2024 value_usd")
|
||||
month(i, 6) = sp("package")("mpvt")(i)("2025 base value_usd")
|
||||
month(i, 7) = sp("package")("mpvt")(i)("2025 adj value_usd")
|
||||
month(i, 8) = sp("package")("mpvt")(i)("2025 tot value_usd")
|
||||
If co_num(month(i, 2), 0) = 0 Then
|
||||
month(i, 9) = "addmonth"
|
||||
Else
|
||||
month(i, 9) = "scale"
|
||||
End If
|
||||
Next i
|
||||
|
||||
Me.crunch_array
|
||||
|
||||
ReDim basket(sp("package")("basket").Count, 3)
|
||||
basket(0, 0) = "part_descr"
|
||||
basket(0, 1) = "bill_cust_descr"
|
||||
basket(0, 2) = "ship_cust_descr"
|
||||
basket(0, 3) = "mix"
|
||||
|
||||
For i = 1 To UBound(basket, 1)
|
||||
basket(i, 0) = sp("package")("basket")(i)("part_descr")
|
||||
basket(i, 1) = sp("package")("basket")(i)("bill_cust_descr")
|
||||
basket(i, 2) = sp("package")("basket")(i)("ship_cust_descr")
|
||||
basket(i, 3) = sp("package")("basket")(i)("mix")
|
||||
Next i
|
||||
|
||||
'-------------load tags-------------------------------
|
||||
cbTAG.list = shConfig.ListObjects("TAGS").DataBodyRange.Value
|
||||
|
||||
'----------reset spinner buttons----------------------
|
||||
sbpv.Value = 0
|
||||
sbpp.Value = 0
|
||||
sbpd.Value = 0
|
||||
|
||||
Call handler.month_tosheet(month, basket)
|
||||
Application.StatusBar = False
|
||||
|
||||
Me.mp.Visible = True
|
||||
Me.fraExit.Visible = True
|
||||
End Sub
|
||||
|
||||
Sub crunch_array()
|
||||
|
||||
Dim i As Integer
|
||||
|
||||
month(13, 1) = 0
|
||||
month(13, 2) = 0
|
||||
month(13, 3) = 0
|
||||
month(13, 4) = 0
|
||||
month(13, 5) = 0
|
||||
month(13, 6) = 0
|
||||
month(13, 7) = 0
|
||||
month(13, 8) = 0
|
||||
|
||||
For i = 1 To 12
|
||||
month(13, 1) = month(13, 1) + co_num(month(i, 1), 0)
|
||||
month(13, 2) = month(13, 2) + co_num(month(i, 2), 0)
|
||||
month(13, 3) = month(13, 3) + co_num(month(i, 3), 0)
|
||||
month(13, 4) = month(13, 4) + co_num(month(i, 4), 0)
|
||||
month(13, 5) = month(13, 5) + co_num(month(i, 5), 0)
|
||||
month(13, 6) = month(13, 6) + co_num(month(i, 6), 0)
|
||||
month(13, 7) = month(13, 7) + co_num(month(i, 7), 0)
|
||||
month(13, 8) = month(13, 8) + co_num(month(i, 8), 0)
|
||||
Next i
|
||||
|
||||
ReDim mload(UBound(month, 1), 5)
|
||||
For i = 0 To UBound(month, 1)
|
||||
mload(i, 0) = month(i, 0)
|
||||
mload(i, 1) = Format(month(i, 1), "#,###")
|
||||
mload(i, 2) = Format(month(i, 4), "#,###")
|
||||
mload(i, 3) = Format(month(i, 5), "#,###")
|
||||
mload(i, 4) = Format(month(i, 8), "#,###")
|
||||
Next i
|
||||
End Sub
|
||||
|
||||
Public Function rev_cust(cust As String) As String
|
||||
If cust = "" Then
|
||||
rev_cust = ""
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If InStr(1, cust, " - ") <= 9 Then
|
||||
rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8))
|
||||
Else
|
||||
rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - "))
|
||||
End If
|
||||
|
||||
End Function
|
||||
|
||||
Sub load_mbox_ann()
|
||||
|
||||
load_tb = True
|
||||
|
||||
tbBaseVol = Format(bVol, "#,##0")
|
||||
tbBaseVal = Format(bVal, "#,##0")
|
||||
tbBasePrice = Format(bPrc, "0.00000")
|
||||
|
||||
tbPadjVol = Format(pVol, "#,##0")
|
||||
tbPadjVal = Format(pVal, "#,##0")
|
||||
tbPadjPrice = Format(pPrc, "0.00000")
|
||||
|
||||
tbFcVol = Format(fVol, "#,##0")
|
||||
tbFcVal = Format(fVal, "#,##0")
|
||||
If Not set_Price Then tbFcPrice = Format(fPrc, "0.00000")
|
||||
|
||||
tbAdjVol = Format(aVol, "#,##0")
|
||||
tbAdjVal = Format(aVal, "#,##0")
|
||||
tbAdjPrice = Format(aPrc, "0.00000")
|
||||
|
||||
load_tb = False
|
||||
End Sub
|
||||
|
||||
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
|
||||
|
||||
If Not IsNumeric(one) Or IsNull(one) Then
|
||||
co_num = two
|
||||
Else
|
||||
co_num = one
|
||||
End If
|
||||
|
||||
End Function
|
||||
|
||||
Sub calc_val()
|
||||
|
||||
Dim pchange As Double
|
||||
|
||||
If IsNumeric(tbFcVal.Value) Then
|
||||
'get textbox value
|
||||
fVal = tbFcVal.Value
|
||||
'do calculations
|
||||
aVal = fVal - bVal - pVal
|
||||
|
||||
'---------if volume adjustment method is selected, scale the volume up----------------------------------
|
||||
If opPlugVol Then
|
||||
If (Round(pVal, 2) + Round(bVal, 2)) = 0 Then
|
||||
pchange = 0
|
||||
If co_num(pVal, bVal) = 0 Then
|
||||
MsgBox "Zero times any number is zero. Cannot scale to get to the target."
|
||||
Else
|
||||
fVol = fVal / (co_num(bVal, pVal) / co_num(bVol, pVol))
|
||||
End If
|
||||
Else
|
||||
pchange = fVal / (pVal + bVal)
|
||||
fVol = (pVol + bVol) * pchange
|
||||
End If
|
||||
|
||||
Else
|
||||
fVol = pVol + bVol
|
||||
End If
|
||||
If fVol = 0 Then
|
||||
fPrc = 0
|
||||
Else
|
||||
fPrc = fVal / fVol
|
||||
End If
|
||||
aVol = fVol - (bVol + pVol)
|
||||
aPrc = fPrc - (bPrc + pPrc)
|
||||
Else
|
||||
aVol = fVol - bVol - pVol
|
||||
aPrc = 0
|
||||
|
||||
End If
|
||||
tbFcVal = Format(co_num(tbFcVal, 0), "#,##0")
|
||||
|
||||
Me.load_mbox_ann
|
||||
|
||||
'build json
|
||||
Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
|
||||
adjust("scenario")("version") = handler.plan
|
||||
adjust("scenario")("iter") = handler.basis
|
||||
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
|
||||
adjust("user") = Application.UserName
|
||||
adjust("source") = "adj"
|
||||
adjust("message") = tbCOM.text
|
||||
adjust("tag") = cbTAG.text
|
||||
If opEditSales Then
|
||||
If opPlugVol Then
|
||||
adjust("type") = "scale_v"
|
||||
adjust("amount") = aVal
|
||||
adjust("qty") = aVol
|
||||
Else
|
||||
adjust("type") = "scale_p"
|
||||
adjust("amount") = aVal
|
||||
End If
|
||||
Else
|
||||
adjust("type") = "scale_vp"
|
||||
adjust("qty") = aVol
|
||||
adjust("amount") = aVal
|
||||
End If
|
||||
|
||||
'print json
|
||||
tbAPI = JsonConverter.ConvertToJson(adjust)
|
||||
End Sub
|
||||
|
||||
Sub calc_price()
|
||||
fVol = co_num(tbFcVol.Value, 0)
|
||||
fPrc = co_num(tbFcPrice.Value, 0)
|
||||
'calc
|
||||
fVal = fPrc * fVol
|
||||
aVal = fVal - bVal - pVal
|
||||
aVol = fVol - (bVol + pVol)
|
||||
|
||||
If (bVol + pVol) = 0 Then
|
||||
aPrc = 0
|
||||
Else
|
||||
'aPrc = fVal / fVol - ((bVal + pVal) / (bVol + pVol))
|
||||
aPrc = fPrc - (bPrc + pPrc)
|
||||
End If
|
||||
'End If
|
||||
|
||||
Me.load_mbox_ann
|
||||
|
||||
'build json
|
||||
Set adjust = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
|
||||
adjust("scenario")("version") = handler.plan
|
||||
adjust("scenario")("iter") = handler.basis
|
||||
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
|
||||
adjust("user") = Application.UserName
|
||||
adjust("source") = "adj"
|
||||
adjust("message") = tbCOM.text
|
||||
adjust("tag") = cbTAG.text
|
||||
adjust("version") = handler.plan
|
||||
|
||||
If opEditSales Then
|
||||
If opPlugVol Then
|
||||
adjust("type") = "scale_v"
|
||||
adjust("amount") = aVal
|
||||
Else
|
||||
adjust("type") = "scale_p"
|
||||
adjust("amount") = aVal
|
||||
End If
|
||||
Else
|
||||
If aVol = 0 Then
|
||||
adjust("type") = "scale_p"
|
||||
Else
|
||||
adjust("type") = "scale_vp"
|
||||
End If
|
||||
adjust("qty") = aVol
|
||||
adjust("amount") = aVal
|
||||
End If
|
||||
|
||||
'print json
|
||||
tbAPI = JsonConverter.ConvertToJson(adjust)
|
||||
End Sub
|
||||
|
||||
Function iter_def(ByVal iter As String) As String
|
||||
|
||||
Dim i As Integer
|
||||
|
||||
For i = 0 To UBound(handler.baseline)
|
||||
If handler.baseline(i) = iter Then
|
||||
iter_def = "baseline"
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
For i = 0 To UBound(handler.adjust)
|
||||
If handler.adjust(i) = iter Then
|
||||
iter_def = "adjust"
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
iter_def = "exclude"
|
||||
|
||||
End Function
|
||||
|
||||
|
||||
|
||||
|
||||
BIN
Master Template.xlsm_EXPORTS/fpvt.frx
Normal file
BIN
Master Template.xlsm_EXPORTS/fpvt.frx
Normal file
Binary file not shown.
655
Master Template.xlsm_EXPORTS/handler.bas
Normal file
655
Master Template.xlsm_EXPORTS/handler.bas
Normal file
@ -0,0 +1,655 @@
|
||||
Attribute VB_Name = "handler"
|
||||
Option Explicit
|
||||
|
||||
Public sql As String
|
||||
Public jsql As String
|
||||
Public scenario As String
|
||||
Public sc() As Variant
|
||||
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....."
|
||||
|
||||
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
|
||||
Debug.Print "GET /scenario_package (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
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(catg As String, rep As String)
|
||||
|
||||
Dim req As New WinHttp.WinHttpRequest
|
||||
Dim wr As String
|
||||
Dim json As Object
|
||||
Dim doc As String
|
||||
Dim res() As Variant
|
||||
|
||||
doc = "{""scenario"":{""" & catg & """:""" & rep & """}}"
|
||||
|
||||
Application.StatusBar = "Querying for " & rep & "'s pool of data..."
|
||||
With req
|
||||
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
|
||||
.Open "GET", handler.server & "/get_pool", True
|
||||
.SetRequestHeader "Content-Type", "application/json"
|
||||
.Send doc
|
||||
Debug.Print "GET /get_pool (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
End With
|
||||
|
||||
If Mid(wr, 1, 1) <> "{" Then
|
||||
MsgBox (wr)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Application.StatusBar = "Parsing query results..."
|
||||
Set json = JsonConverter.ParseJson(wr)
|
||||
|
||||
If IsNull(json("x")) Then
|
||||
MsgBox "No data found for " & rep & "."
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
ReDim res(0, 34)
|
||||
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"
|
||||
res(0, 34) = "pounds"
|
||||
|
||||
shData.Cells.ClearContents
|
||||
Call Utils.SHTp_DumpVar(res, shData.Name, 1, 1, False, True, True)
|
||||
|
||||
Dim batchSize As Integer
|
||||
batchSize = 1000
|
||||
Dim totalRows As Long
|
||||
totalRows = json("x").Count
|
||||
Dim jsonRow As Long
|
||||
jsonRow = 1
|
||||
Dim sheetRow As Long
|
||||
sheetRow = 2
|
||||
Dim arrayRow As Long
|
||||
|
||||
' While the JSON array still has rows,
|
||||
' 1. move the 1st one to a VBA 2-D array, deleting it from the JSON array.
|
||||
' 2. When 1000 have been copied, put the values onto the worksheet, and
|
||||
' empty the VBA array.
|
||||
' Splitting the JSON array into smaller batches when creating the VBA array
|
||||
' means there is less memory needed for the operation.
|
||||
Do While json("x").Count > 0
|
||||
If jsonRow Mod batchSize = 1 Then
|
||||
ReDim res(batchSize - 1, 34)
|
||||
arrayRow = 0
|
||||
End If
|
||||
res(arrayRow, 0) = json("x")(1)("bill_cust_descr")
|
||||
res(arrayRow, 1) = json("x")(1)("billto_group")
|
||||
res(arrayRow, 2) = json("x")(1)("ship_cust_descr")
|
||||
res(arrayRow, 3) = json("x")(1)("shipto_group")
|
||||
res(arrayRow, 4) = json("x")(1)("quota_rep_descr")
|
||||
res(arrayRow, 5) = json("x")(1)("director")
|
||||
res(arrayRow, 6) = json("x")(1)("segm")
|
||||
res(arrayRow, 7) = json("x")(1)("substance")
|
||||
res(arrayRow, 8) = json("x")(1)("chan")
|
||||
res(arrayRow, 9) = json("x")(1)("chansub")
|
||||
res(arrayRow, 10) = json("x")(1)("part_descr")
|
||||
res(arrayRow, 11) = json("x")(1)("part_group")
|
||||
res(arrayRow, 12) = json("x")(1)("branding")
|
||||
res(arrayRow, 13) = json("x")(1)("majg_descr")
|
||||
res(arrayRow, 14) = json("x")(1)("ming_descr")
|
||||
res(arrayRow, 15) = json("x")(1)("majs_descr")
|
||||
res(arrayRow, 16) = json("x")(1)("mins_descr")
|
||||
res(arrayRow, 17) = json("x")(1)("order_season")
|
||||
res(arrayRow, 18) = json("x")(1)("order_month")
|
||||
res(arrayRow, 19) = json("x")(1)("ship_season")
|
||||
res(arrayRow, 20) = json("x")(1)("ship_month")
|
||||
res(arrayRow, 21) = json("x")(1)("request_season")
|
||||
res(arrayRow, 22) = json("x")(1)("request_month")
|
||||
res(arrayRow, 23) = json("x")(1)("promo")
|
||||
res(arrayRow, 24) = json("x")(1)("value_loc")
|
||||
res(arrayRow, 25) = json("x")(1)("value_usd")
|
||||
res(arrayRow, 26) = json("x")(1)("cost_loc")
|
||||
res(arrayRow, 27) = json("x")(1)("cost_usd")
|
||||
res(arrayRow, 28) = json("x")(1)("units")
|
||||
res(arrayRow, 29) = json("x")(1)("version")
|
||||
res(arrayRow, 30) = json("x")(1)("iter")
|
||||
res(arrayRow, 31) = json("x")(1)("logid")
|
||||
res(arrayRow, 32) = json("x")(1)("tag")
|
||||
res(arrayRow, 33) = json("x")(1)("comment")
|
||||
res(arrayRow, 34) = json("x")(1)("pounds")
|
||||
json("x").Remove 1
|
||||
arrayRow = arrayRow + 1
|
||||
If jsonRow Mod batchSize = 0 Or json("x").Count = 0 Then
|
||||
Application.StatusBar = "Populating spreadsheet: " & Format(jsonRow, "#,##0") & " of " & Format(totalRows, "#,##0") & " rows..."
|
||||
Call Utils.SHTp_DumpVar(res, shData.Name, sheetRow, 1, False, True, True)
|
||||
sheetRow = sheetRow + batchSize
|
||||
End If
|
||||
jsonRow = jsonRow + 1
|
||||
Loop
|
||||
|
||||
Set json = Nothing
|
||||
Application.StatusBar = False
|
||||
End Sub
|
||||
|
||||
Sub pull_rep()
|
||||
openf.Show
|
||||
End Sub
|
||||
|
||||
|
||||
|
||||
Function request_adjust(doc As String, ByRef msg As String) As Boolean
|
||||
|
||||
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
|
||||
|
||||
request_adjust = False
|
||||
|
||||
If doc = "" Then
|
||||
msg = "No data was given to be processed."
|
||||
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 = shConfig.Range("server").Value
|
||||
|
||||
With req
|
||||
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
|
||||
.Open "POST", server & "/" & json("type"), True
|
||||
.SetRequestHeader "Content-Type", "application/json"
|
||||
.Send doc
|
||||
Debug.Print "GET /"; json("type"); " (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
End With
|
||||
|
||||
If Mid(wr, 2, 5) = "error" Or _
|
||||
Mid(wr, 1, 6) = "<body>" Or _
|
||||
Mid(wr, 1, 6) = "<!DOCT" _
|
||||
Then
|
||||
msg = wr
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If Mid(wr, 1, 6) = "null" Then
|
||||
msg = "API route not implemented"
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Set json = JsonConverter.ParseJson(wr)
|
||||
|
||||
If IsNull(json("x")) Then
|
||||
msg = "No adjustment was made."
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
ReDim res(json("x").Count - 1, 34)
|
||||
|
||||
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")
|
||||
res(i, 34) = json("x")(i + 1)("pounds")
|
||||
Next i
|
||||
|
||||
request_adjust = True
|
||||
|
||||
i = shData.UsedRange.Rows.Count + 1
|
||||
Call Utils.SHTp_DumpVar(res, shData.Name, i, 1, False, False, True)
|
||||
shOrders.PivotTables("ptOrders").PivotCache.Refresh
|
||||
|
||||
End Function
|
||||
|
||||
Sub load_config()
|
||||
|
||||
Dim i As Integer
|
||||
'----server to use---------------------------------------------------------
|
||||
handler.server = shConfig.Range("server").Value
|
||||
'---basis------------------------------------------------------------------
|
||||
With shConfig.ListObjects("BASIS")
|
||||
For i = 1 To .DataBodyRange.Rows.Count
|
||||
ReDim Preserve handler.basis(i - 1)
|
||||
handler.basis(i - 1) = .DataBodyRange(i, 1)
|
||||
Next
|
||||
End With
|
||||
'---baseline-----------------------------------------------------------------
|
||||
With shConfig.ListObjects("BASELINE")
|
||||
For i = 1 To .DataBodyRange.Rows.Count
|
||||
ReDim Preserve handler.baseline(i - 1)
|
||||
handler.baseline(i - 1) = .DataBodyRange(i, 1)
|
||||
Next
|
||||
End With
|
||||
'---adjustments-----------------------------------------------------------------
|
||||
With shConfig.ListObjects("ADJUST")
|
||||
For i = 1 To .DataBodyRange.Rows.Count
|
||||
ReDim Preserve handler.adjust(i - 1)
|
||||
handler.adjust(i - 1) = .DataBodyRange(i, 1)
|
||||
Next
|
||||
End With
|
||||
'---plan version--------------------------------------------------------------
|
||||
handler.plan = shConfig.Range("budget").Value
|
||||
|
||||
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
|
||||
|
||||
With shMonthUpdate
|
||||
|
||||
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
|
||||
.Cells(1, 16) = JsonConverter.ConvertToJson(j)
|
||||
|
||||
For i = 1 To 12
|
||||
'------------volume-------------------
|
||||
.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
|
||||
.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
|
||||
.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
|
||||
.Cells(i + 1, 4) = 0
|
||||
.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
|
||||
|
||||
'------------value----------------------
|
||||
.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
|
||||
.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
|
||||
.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
|
||||
.Cells(i + 1, 14) = 0
|
||||
.Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
|
||||
|
||||
'-------------price----------------------
|
||||
If i > 0 Then
|
||||
'--prior--
|
||||
If co_num(pkg(i, 1), 0) = 0 Then
|
||||
.Cells(i + 1, 6) = 0
|
||||
Else
|
||||
.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 .Cells(i, 7) <> 0 Then
|
||||
.Cells(i + 1, 7) = .Cells(i, 7)
|
||||
Else
|
||||
If pkg(13, 1) + pkg(13, 2) = 0 Then
|
||||
.Cells(i + 1, 7) = 0
|
||||
Else
|
||||
.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
.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
|
||||
.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
|
||||
|
||||
Next i
|
||||
|
||||
'scenario
|
||||
.Range("R1:S1000").ClearContents
|
||||
For i = 0 To UBound(handler.sc, 1)
|
||||
.Cells(i + 1, 18) = handler.sc(i, 0)
|
||||
.Cells(i + 1, 19) = handler.sc(i, 1)
|
||||
Next i
|
||||
|
||||
'basket
|
||||
.Range("U1:AC100000").ClearContents
|
||||
Call Utils.SHTp_DumpVar(basket, .Name, 1, 21, False, False, True)
|
||||
Call Utils.SHTp_DumpVar(basket, .Name, 1, 26, False, False, True)
|
||||
shConfig.Range("rebuild").Value = 0
|
||||
shConfig.Range("show_basket").Value = 0
|
||||
shConfig.Range("new_part").Value = 0
|
||||
|
||||
shMonthView.LoadSheet
|
||||
|
||||
End With
|
||||
|
||||
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 Long
|
||||
Dim j As Long
|
||||
Dim res() As Variant
|
||||
|
||||
If doc = "" Then
|
||||
fail = True
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
server = shConfig.Range("server").Value
|
||||
|
||||
With req
|
||||
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
|
||||
.Open "GET", server & "/list_changes", True
|
||||
.SetRequestHeader "Content-Type", "application/json"
|
||||
.Send doc
|
||||
Debug.Print "GET /list_changes (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
End With
|
||||
|
||||
Set json = JsonConverter.ParseJson(wr)
|
||||
|
||||
If IsNull(json("x")) Then
|
||||
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 Long
|
||||
Dim j As Long
|
||||
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
|
||||
Debug.Print "GET /undo_change (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
End With
|
||||
|
||||
Set json = JsonConverter.ParseJson(wr)
|
||||
logid = json("x")(1)("id")
|
||||
|
||||
'---------loop through and get a list of each row that needs deleted?-----
|
||||
|
||||
j = 0
|
||||
For i = 1 To 100
|
||||
If shData.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
|
||||
With shData
|
||||
While .Cells(i, 1) <> ""
|
||||
If .Cells(i, j) = logid Then
|
||||
.Rows(i).Delete
|
||||
Else
|
||||
i = i + 1
|
||||
End If
|
||||
Wend
|
||||
End With
|
||||
|
||||
End Function
|
||||
|
||||
|
||||
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 = shConfig.Range("server").Value
|
||||
|
||||
With req
|
||||
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
|
||||
.Open "GET", server & "/swap_fit", True
|
||||
.SetRequestHeader "Content-Type", "application/json"
|
||||
.Send doc
|
||||
Debug.Print "GET /swap_fit (";
|
||||
Dim t As Single
|
||||
t = Timer
|
||||
.WaitForResponse
|
||||
wr = .ResponseText
|
||||
Debug.Print Timer - t; "sec): "; Left(wr, 200)
|
||||
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
|
||||
|
||||
|
||||
|
||||
64
Master Template.xlsm_EXPORTS/openf.frm
Normal file
64
Master Template.xlsm_EXPORTS/openf.frm
Normal file
@ -0,0 +1,64 @@
|
||||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf
|
||||
Caption = "Open a Forecast"
|
||||
ClientHeight = 2400
|
||||
ClientLeft = 120
|
||||
ClientTop = 465
|
||||
ClientWidth = 8220.001
|
||||
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()
|
||||
If opDSM.Value Then
|
||||
Call handler.pg_main_workset("quota_rep_descr", cbDSM.Value)
|
||||
ElseIf opDirector.Value Then
|
||||
Call handler.pg_main_workset("director", cbDirector.Value)
|
||||
ElseIf opSegment.Value Then
|
||||
Call handler.pg_main_workset("segm", cbSegment.Value)
|
||||
End If
|
||||
shOrders.PivotTables("ptOrders").PivotCache.Refresh
|
||||
openf.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub cbOK_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
|
||||
If Button = 2 And Shift = 2 Then
|
||||
shConfig.Range("debug_mode") = Not shConfig.Range("debug_mode")
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Sub opDSM_Click()
|
||||
cbDSM.Visible = True
|
||||
cbDirector.Visible = False
|
||||
cbSegment.Visible = False
|
||||
End Sub
|
||||
|
||||
Private Sub opDirector_Click()
|
||||
cbDSM.Visible = False
|
||||
cbDirector.Visible = True
|
||||
cbSegment.Visible = False
|
||||
End Sub
|
||||
|
||||
Private Sub opSegment_Click()
|
||||
cbDSM.Visible = False
|
||||
cbDirector.Visible = False
|
||||
cbSegment.Visible = True
|
||||
End Sub
|
||||
|
||||
Private Sub UserForm_Activate()
|
||||
handler.server = shConfig.Range("server").Value
|
||||
cbDSM.list = shSupportingData.ListObjects("DSM").DataBodyRange.Value
|
||||
cbDirector.list = shConfig.ListObjects("DIRECTORS").DataBodyRange.Value
|
||||
cbSegment.list = shConfig.ListObjects("SEGMENTS").DataBodyRange.Value
|
||||
End Sub
|
||||
|
||||
|
||||
|
||||
BIN
Master Template.xlsm_EXPORTS/openf.frx
Normal file
BIN
Master Template.xlsm_EXPORTS/openf.frx
Normal file
Binary file not shown.
35
Master Template.xlsm_EXPORTS/part.frm
Normal file
35
Master Template.xlsm_EXPORTS/part.frm
Normal file
@ -0,0 +1,35 @@
|
||||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} part
|
||||
Caption = "Part Picker"
|
||||
ClientHeight = 1335
|
||||
ClientLeft = 120
|
||||
ClientTop = 465
|
||||
ClientWidth = 9285.001
|
||||
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
|
||||
Option Explicit
|
||||
|
||||
Public useval As Boolean
|
||||
|
||||
Private Sub cmdCancel_Click()
|
||||
useval = False
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub cmdOK_Click()
|
||||
useval = True
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub UserForm_Activate()
|
||||
useval = False
|
||||
cbPart.list = shSupportingData.ListObjects("ITEM").DataBodyRange.Value
|
||||
End Sub
|
||||
|
||||
|
||||
BIN
Master Template.xlsm_EXPORTS/part.frx
Normal file
BIN
Master Template.xlsm_EXPORTS/part.frx
Normal file
Binary file not shown.
31
Master Template.xlsm_EXPORTS/shConfig.cls
Normal file
31
Master Template.xlsm_EXPORTS/shConfig.cls
Normal file
@ -0,0 +1,31 @@
|
||||
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
|
||||
Option Explicit
|
||||
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
If Intersect(Target, shConfig.Range("debug_mode")) Is Nothing Then Exit Sub
|
||||
|
||||
If shConfig.Range("debug_mode").Value Then
|
||||
shConfig.Visible = xlSheetVisible
|
||||
'shData.Visible = xlSheetVisible
|
||||
shMonthView.Visible = xlSheetVisible
|
||||
shMonthUpdate.Visible = xlSheetVisible
|
||||
shSupportingData.Visible = xlSheetVisible
|
||||
shWalk.Visible = xlSheetVisible
|
||||
Else
|
||||
shConfig.Visible = xlSheetVeryHidden
|
||||
'shData.Visible = xlSheetHidden
|
||||
shMonthView.Visible = xlSheetHidden
|
||||
shMonthUpdate.Visible = xlSheetVeryHidden
|
||||
shSupportingData.Visible = xlSheetVeryHidden
|
||||
shWalk.Visible = xlSheetVeryHidden
|
||||
End If
|
||||
End Sub
|
||||
|
||||
9
Master Template.xlsm_EXPORTS/shData.cls
Normal file
9
Master Template.xlsm_EXPORTS/shData.cls
Normal 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
|
||||
11
Master Template.xlsm_EXPORTS/shHelp.cls
Normal file
11
Master Template.xlsm_EXPORTS/shHelp.cls
Normal file
@ -0,0 +1,11 @@
|
||||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "shHelp"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = True
|
||||
Option Explicit
|
||||
|
||||
9
Master Template.xlsm_EXPORTS/shMonthUpdate.cls
Normal file
9
Master Template.xlsm_EXPORTS/shMonthUpdate.cls
Normal 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
|
||||
905
Master Template.xlsm_EXPORTS/shMonthView.cls
Normal file
905
Master Template.xlsm_EXPORTS/shMonthView.cls
Normal file
@ -0,0 +1,905 @@
|
||||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "shMonthView"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = True
|
||||
Option Explicit
|
||||
|
||||
Private units() As Variant
|
||||
Private price() As Variant
|
||||
Private sales() As Variant
|
||||
Private tunits() As Variant
|
||||
Private tprice() As Variant
|
||||
Private tsales() As Variant
|
||||
Private busy As Boolean
|
||||
Private vedit As String
|
||||
Private adjust() As Object
|
||||
Private jtext() As Variant
|
||||
Private rollback As Boolean
|
||||
Private scenario() As Variant
|
||||
Private orig As Range
|
||||
Private showbasket As Boolean
|
||||
Private np As Object 'json dedicated to new part scenario
|
||||
Private did_load_config As Boolean
|
||||
|
||||
Public Sub MPP_Down() ' Handler for down-triangle on price percent change.
|
||||
If newpart Then Exit Sub
|
||||
|
||||
With shMonthView.Range("PricePctChange")
|
||||
.Value = WorksheetFunction.Max(-0.1, .Value - 0.01)
|
||||
End With
|
||||
MPP_Change
|
||||
End Sub
|
||||
|
||||
Public Sub MPP_Up() ' Handler for up-triangle on price percent change.
|
||||
If newpart Then Exit Sub
|
||||
|
||||
With shMonthView.Range("PricePctChange")
|
||||
.Value = WorksheetFunction.Min(0.1, .Value + 0.01)
|
||||
End With
|
||||
MPP_Change
|
||||
End Sub
|
||||
|
||||
Private Sub MPP_Change()
|
||||
Dim i As Long
|
||||
|
||||
Application.ScreenUpdating = False
|
||||
|
||||
busy = True
|
||||
|
||||
With shMonthView
|
||||
For i = 1 To 12
|
||||
If .Range("PriceBaseline").Cells(i) > 0 Then
|
||||
.Range("PriceNewAdj").Cells(i) = .Range("PriceBaseline").Cells(i) * .Range("PricePctChange")
|
||||
End If
|
||||
Next i
|
||||
End With
|
||||
Me.mvp_adj
|
||||
|
||||
busy = False
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
End Sub
|
||||
|
||||
|
||||
Public Sub MPV_Down() ' Handler for down-triangle on qty percent change.
|
||||
If newpart Then Exit Sub
|
||||
|
||||
With shMonthView.Range("QtyPctChange")
|
||||
.Value = WorksheetFunction.Max(-0.1, .Value - 0.01)
|
||||
End With
|
||||
MPV_Change
|
||||
End Sub
|
||||
|
||||
Public Sub MPV_Up() ' Handler for up-triangle on qty percent change.
|
||||
If newpart Then Exit Sub
|
||||
|
||||
With shMonthView.Range("QtyPctChange")
|
||||
.Value = WorksheetFunction.Min(0.1, .Value + 0.01)
|
||||
End With
|
||||
MPV_Change
|
||||
End Sub
|
||||
|
||||
Private Sub MPV_Change()
|
||||
Dim i As Long
|
||||
|
||||
Application.ScreenUpdating = False
|
||||
|
||||
busy = True
|
||||
|
||||
With shMonthView
|
||||
For i = 1 To 12
|
||||
If .Range("QtyBaseline").Cells(i) <> 0 Then
|
||||
.Range("QtyNewAdj").Cells(i) = .Range("QtyBaseline").Cells(i) * .Range("QtyPctChange")
|
||||
End If
|
||||
Next i
|
||||
End With
|
||||
|
||||
busy = False
|
||||
|
||||
Call Me.mvp_adj
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
End Sub
|
||||
|
||||
Public Sub ToggleVolumePrice()
|
||||
shMonthView.Range("MonthAdjustVolume").Value = (shMonthView.Range("MonthAdjustVolume").Value <> True)
|
||||
shMonthView.Range("MonthAdjustPrice").Value = Not shMonthView.Range("MonthAdjustVolume").Value
|
||||
End Sub
|
||||
|
||||
Private Sub Worksheet_Change(ByVal Target As Range)
|
||||
'---this needs checked prior to busy check because % increase spinners are flagged as dumps
|
||||
If Not did_load_config Then
|
||||
Call handler.load_config
|
||||
did_load_config = True
|
||||
End If
|
||||
|
||||
If busy Then Exit Sub
|
||||
|
||||
If (IntersectsWith(Target, Range("units")) Or _
|
||||
IntersectsWith(Target, Range("price")) Or _
|
||||
IntersectsWith(Target, Range("sales"))) And _
|
||||
Target.Columns.Count > 1 _
|
||||
Then
|
||||
MsgBox "You can only change one column at a time. Your change will be undone."
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
If IntersectsWith(Target, Range("QtyNewAdj")) Then Call Me.mvp_adj
|
||||
If IntersectsWith(Target, Range("QtyFinal")) Then Call Me.mvp_set
|
||||
If IntersectsWith(Target, Range("PriceNewAdj")) Then Call Me.mvp_adj
|
||||
If IntersectsWith(Target, Range("PriceFinal")) Then Call Me.mvp_set
|
||||
If IntersectsWith(Target, Range("SalesNewAdj")) Then Call Me.ms_adj
|
||||
If IntersectsWith(Target, Range("SalesFinal")) Then Call Me.ms_set
|
||||
|
||||
If IntersectsWith(Target, Range("basket")) And shConfig.Range("show_basket").Value = 1 Then
|
||||
If RemoveEmptyBasketLines Then ' Lines were removed
|
||||
GetEditBasket shMonthView.Range("basket").Resize(1, 1) ' Don't "touch" the mix column, so as to rescale all rows proportionally to 100% total.
|
||||
Else
|
||||
GetEditBasket Target
|
||||
End If
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
|
||||
If IntersectsWith(Target, Union(Range("basket_new_item"), Range("basket"))) And shConfig.Range("show_basket").Value = 1 Then
|
||||
Cancel = True
|
||||
Call Me.basket_pick(Target)
|
||||
Target.Select
|
||||
End If
|
||||
End Sub
|
||||
|
||||
|
||||
Sub picker_shortcut()
|
||||
If IntersectsWith(Selection, Range("basket")) And shConfig.Range("show_basket").Value = 1 Then
|
||||
Call Me.basket_pick(Selection)
|
||||
End If
|
||||
|
||||
End Sub
|
||||
|
||||
Public Function rev_cust(cust As String) As String
|
||||
|
||||
If cust = "" Then
|
||||
rev_cust = ""
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If InStr(1, cust, " - ") <= 9 Then
|
||||
rev_cust = trim(Mid(cust, 11, 100)) & " - " & trim(Left(cust, 8))
|
||||
Else
|
||||
rev_cust = trim(Right(cust, 8)) & " - " & Mid(cust, 1, InStr(1, cust, " - "))
|
||||
End If
|
||||
|
||||
End Function
|
||||
|
||||
Sub mvp_set()
|
||||
|
||||
Dim i As Integer
|
||||
GetSheet
|
||||
|
||||
For i = 1 To 12
|
||||
If units(i, 5) = "" Then units(i, 5) = 0
|
||||
If price(i, 5) = "" Then price(i, 5) = 0
|
||||
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
|
||||
price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3))
|
||||
sales(i, 5) = units(i, 5) * price(i, 5)
|
||||
If units(i, 4) = 0 And price(i, 4) = 0 Then
|
||||
sales(i, 4) = 0
|
||||
Else
|
||||
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
|
||||
End If
|
||||
Next i
|
||||
|
||||
CrunchArray
|
||||
BuildJson
|
||||
SetSheet
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub mvp_adj()
|
||||
|
||||
Dim i As Integer
|
||||
GetSheet
|
||||
|
||||
For i = 1 To 12
|
||||
If units(i, 4) = "" Then units(i, 4) = 0
|
||||
If price(i, 4) = "" Then price(i, 4) = 0
|
||||
units(i, 5) = units(i, 4) + (units(i, 2) + units(i, 3))
|
||||
price(i, 5) = price(i, 4) + (price(i, 2) + price(i, 3))
|
||||
sales(i, 5) = units(i, 5) * price(i, 5)
|
||||
If units(i, 4) = 0 And price(i, 4) = 0 Then
|
||||
sales(i, 4) = 0
|
||||
Else
|
||||
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
|
||||
End If
|
||||
Next i
|
||||
|
||||
CrunchArray
|
||||
BuildJson
|
||||
SetSheet
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub ms_set()
|
||||
|
||||
On Error GoTo errh
|
||||
|
||||
Dim i As Integer
|
||||
GetSheet
|
||||
|
||||
For i = 1 To 12
|
||||
If sales(i, 5) = "" Then sales(i, 5) = 0
|
||||
If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 2) <> Round(sales(i, 4), 2) Then
|
||||
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
|
||||
|
||||
If shMonthView.Range("MonthAdjustVolume") Then
|
||||
If co_num(price(i, 5), 0) = 0 Then
|
||||
MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
units(i, 5) = sales(i, 5) / price(i, 5)
|
||||
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
|
||||
|
||||
ElseIf shMonthView.Range("MonthAdjustPrice") Then
|
||||
If co_num(units(i, 5), 0) = 0 Then
|
||||
MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
price(i, 5) = sales(i, 5) / units(i, 5)
|
||||
price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3))
|
||||
|
||||
Else
|
||||
MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next i
|
||||
|
||||
CrunchArray
|
||||
BuildJson
|
||||
SetSheet
|
||||
|
||||
errh:
|
||||
If Err.Number <> 0 Then rollback = True
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub ms_adj()
|
||||
|
||||
Dim i As Integer
|
||||
GetSheet
|
||||
|
||||
For i = 1 To 12
|
||||
If sales(i, 4) = "" Then sales(i, 4) = 0
|
||||
If Round(sales(i, 5), 6) <> Round(sales(i, 2) + sales(i, 3) + sales(i, 4), 6) Then
|
||||
sales(i, 5) = sales(i, 4) + sales(i, 2) + sales(i, 3)
|
||||
|
||||
If shMonthView.Range("MonthAdjustVolume") Then
|
||||
If co_num(price(i, 5), 0) = 0 Then
|
||||
MsgBox "Volume cannot be automatically adjusted because price is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
units(i, 5) = sales(i, 5) / price(i, 5)
|
||||
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
|
||||
|
||||
ElseIf shMonthView.Range("MonthAdjustPrice") Then
|
||||
If co_num(units(i, 5), 0) = 0 Then
|
||||
MsgBox "Price cannot be automatically adjusted because volume is 0. Your change will be undone.", vbOKOnly Or vbExclamation, "Division by zero"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
price(i, 5) = sales(i, 5) / units(i, 5)
|
||||
price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3))
|
||||
|
||||
Else
|
||||
MsgBox "Neither Volume or Price was selected. Your change will be undone", vbOKOnly Or vbExclamation, "Bad Setup"
|
||||
busy = True
|
||||
Application.Undo
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next i
|
||||
|
||||
CrunchArray
|
||||
BuildJson
|
||||
SetSheet
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Private Sub GetSheet()
|
||||
With shMonthView
|
||||
units = .Range("units")
|
||||
price = .Range("price")
|
||||
sales = .Range("sales")
|
||||
tunits = .Range("tunits")
|
||||
tprice = .Range("tprice")
|
||||
tsales = .Range("tsales")
|
||||
ReDim adjust(12)
|
||||
End With
|
||||
End Sub
|
||||
|
||||
Private Function basejson() As Object
|
||||
Set basejson = JsonConverter.ParseJson(shMonthUpdate.Range("P1").FormulaR1C1)
|
||||
End Function
|
||||
|
||||
Private Sub SetSheet()
|
||||
|
||||
Dim i As Integer
|
||||
|
||||
busy = True
|
||||
|
||||
With shMonthView
|
||||
.Range("units") = units
|
||||
.Range("price") = price
|
||||
.Range("sales") = sales
|
||||
.Range("tunits").FormulaR1C1 = tunits
|
||||
.Range("tprice").FormulaR1C1 = tprice
|
||||
.Range("tsales").FormulaR1C1 = tsales
|
||||
.Range("scenario").ClearContents
|
||||
|
||||
Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("R1")), .Name, .Range("scenario").row, .Range("scenario").Column, False, False, False)
|
||||
'.Range("B32:Q5000").ClearContents
|
||||
End With
|
||||
|
||||
If Me.newpart Then
|
||||
shMonthUpdate.Range("P2:P13").ClearContents
|
||||
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
|
||||
Else
|
||||
For i = 1 To 12
|
||||
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
|
||||
Next i
|
||||
End If
|
||||
|
||||
busy = False
|
||||
|
||||
End Sub
|
||||
|
||||
Public Sub LoadSheet()
|
||||
|
||||
units = shMonthUpdate.Range("A2:E13").FormulaR1C1
|
||||
price = shMonthUpdate.Range("F2:J13").FormulaR1C1
|
||||
sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
|
||||
scenario = shMonthUpdate.Range("R1:S13").FormulaR1C1
|
||||
tunits = shMonthView.Range("tunits")
|
||||
tprice = shMonthView.Range("tprice")
|
||||
tsales = shMonthView.Range("tsales")
|
||||
'reset basket
|
||||
shMonthUpdate.Range("U1:X10000").ClearContents
|
||||
Call Utils.SHTp_DumpVar(Utils.SHTp_get_block(shMonthUpdate.Range("Z1")), shMonthUpdate.Name, 1, 21, False, False, False)
|
||||
ReDim adjust(12)
|
||||
CrunchArray
|
||||
SetSheet
|
||||
Call Me.print_basket
|
||||
did_load_config = False
|
||||
|
||||
End Sub
|
||||
|
||||
Private Sub BuildJson()
|
||||
|
||||
Dim i As Long
|
||||
Dim j As Long
|
||||
Dim pos As Long
|
||||
Dim o As Object
|
||||
Dim m As Object
|
||||
Dim list As Object
|
||||
|
||||
load_config
|
||||
|
||||
ReDim adjust(12)
|
||||
|
||||
If Me.newpart Then
|
||||
Set np = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson()))
|
||||
np("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
|
||||
np("user") = Application.UserName
|
||||
np("scenario")("version") = handler.plan
|
||||
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy"",""plan""]")
|
||||
np("source") = "adj"
|
||||
np("type") = "new_basket"
|
||||
np("tag") = shMonthView.Range("MonthTag").Value
|
||||
Set m = JsonConverter.ParseJson("{}")
|
||||
End If
|
||||
|
||||
For pos = 1 To 12
|
||||
If Me.newpart Then
|
||||
If sales(pos, 5) <> 0 Then
|
||||
Set o = JsonConverter.ParseJson("{}")
|
||||
o("amount") = sales(pos, 5)
|
||||
o("qty") = units(pos, 5)
|
||||
Set m(shMonthView.Range("OrderMonths").Cells(pos, 1).Value) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(o))
|
||||
End If
|
||||
Else
|
||||
'if something is changing
|
||||
If Round(units(pos, 4), 2) <> 0 Or (Round(price(pos, 4), 8) <> 0 And Round(units(pos, 5), 2) <> 0) Then
|
||||
Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson()))
|
||||
'if there is no existing volume on the target month but units are being added
|
||||
If units(pos, 2) + units(pos, 3) = 0 And units(pos, 4) <> 0 Then
|
||||
'add month
|
||||
adjust(pos)("type") = "addmonth_vp"
|
||||
adjust(pos)("month") = shMonthView.Range("OrderMonths").Cells(pos, 1)
|
||||
adjust(pos)("qty") = units(pos, 4)
|
||||
adjust(pos)("amount") = sales(pos, 4)
|
||||
Else
|
||||
'scale the existing volume(price) on the target month
|
||||
If Round(price(pos, 4), 8) <> 0 Then
|
||||
If Round(units(pos, 4), 2) <> 0 Then
|
||||
adjust(pos)("type") = "scale_vp"
|
||||
Else
|
||||
adjust(pos)("type") = "scale_p"
|
||||
End If
|
||||
Else
|
||||
'if the target price is the same as average and a month is being added
|
||||
adjust(pos)("type") = "scale_v"
|
||||
End If
|
||||
adjust(pos)("qty") = units(pos, 4)
|
||||
adjust(pos)("amount") = sales(pos, 4)
|
||||
'------------add this in to only scale a particular month--------------------
|
||||
adjust(pos)("scenario")("order_month") = shMonthView.Range("OrderMonths").Cells(pos, 1)
|
||||
End If
|
||||
adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
|
||||
adjust(pos)("user") = Application.UserName
|
||||
adjust(pos)("scenario")("version") = handler.plan
|
||||
adjust(pos)("scenario")("iter") = handler.basis
|
||||
adjust(pos)("source") = "adj"
|
||||
End If
|
||||
End If
|
||||
Next pos
|
||||
|
||||
If Me.newpart Then
|
||||
Set np("months") = JsonConverter.ParseJson(JsonConverter.ConvertToJson(m))
|
||||
np("newpart") = shMonthView.Range("basket").Cells(1, 1).Value
|
||||
'get the basket from the sheet
|
||||
Dim basket() As Variant
|
||||
basket = shMonthUpdate.Range("U1").CurrentRegion.Value
|
||||
Set m = JsonConverter.ParseJson(Utils.json_from_table(basket, "basket", False))
|
||||
If UBound(basket, 1) <= 2 Then
|
||||
Set np("basket") = JsonConverter.ParseJson("[" & Utils.json_from_table(basket, "basket", False) & "]")
|
||||
Else
|
||||
Set np("basket") = m("basket")
|
||||
End If
|
||||
End If
|
||||
|
||||
If Me.newpart Then
|
||||
shMonthUpdate.Range("P2:P13").ClearContents
|
||||
shMonthUpdate.Cells(2, 16) = JsonConverter.ConvertToJson(np)
|
||||
Else
|
||||
For i = 1 To 12
|
||||
shMonthUpdate.Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
|
||||
Next i
|
||||
End If
|
||||
|
||||
End Sub
|
||||
|
||||
Private Sub CrunchArray()
|
||||
|
||||
Dim i As Integer
|
||||
Dim j As Integer
|
||||
|
||||
For i = 1 To 5
|
||||
tunits(1, i) = 0
|
||||
tprice(1, i) = 0
|
||||
tsales(1, i) = 0
|
||||
Next i
|
||||
|
||||
For i = 1 To 12
|
||||
For j = 1 To 5
|
||||
tunits(1, j) = tunits(1, j) + units(i, j)
|
||||
tsales(1, j) = tsales(1, j) + sales(i, j)
|
||||
Next j
|
||||
Next i
|
||||
|
||||
'prior
|
||||
If tunits(1, 1) = 0 Then
|
||||
tprice(1, 1) = 0
|
||||
Else
|
||||
tprice(1, 1) = tsales(1, 1) / tunits(1, 1)
|
||||
End If
|
||||
'base
|
||||
If tunits(1, 2) = 0 Then
|
||||
tprice(1, 2) = 0
|
||||
Else
|
||||
tprice(1, 2) = tsales(1, 2) / tunits(1, 2)
|
||||
End If
|
||||
'forecast
|
||||
If tunits(1, 5) <> 0 Then
|
||||
tprice(1, 5) = tsales(1, 5) / tunits(1, 5)
|
||||
Else
|
||||
tprice(1, 5) = 0
|
||||
End If
|
||||
'adjust
|
||||
If (tunits(1, 2) + tunits(1, 3)) = 0 Then
|
||||
tprice(1, 3) = 0
|
||||
Else
|
||||
tprice(1, 3) = (tsales(1, 2) + tsales(1, 3)) / (tunits(1, 2) + tunits(1, 3)) - tprice(1, 2)
|
||||
End If
|
||||
'current adjust
|
||||
tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3))
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub Cancel()
|
||||
|
||||
shOrders.Select
|
||||
|
||||
End Sub
|
||||
|
||||
Sub reset()
|
||||
|
||||
LoadSheet
|
||||
|
||||
End Sub
|
||||
|
||||
Sub switch_basket()
|
||||
shConfig.Range("show_basket").Value = 1 - shConfig.Range("show_basket").Value
|
||||
Call Me.print_basket
|
||||
End Sub
|
||||
|
||||
Sub print_basket()
|
||||
|
||||
If shConfig.Range("show_basket").Value = 0 Then
|
||||
busy = True
|
||||
shMonthView.Range("basket").ClearContents
|
||||
busy = False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim i As Long
|
||||
Dim basket() As Variant
|
||||
basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
|
||||
|
||||
busy = True
|
||||
|
||||
shMonthView.Range("basket").ClearContents
|
||||
For i = 2 To UBound(basket, 1)
|
||||
shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 0).Value = basket(i, 1)
|
||||
shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 4).Value = basket(i, 2)
|
||||
shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 10).Value = basket(i, 3)
|
||||
shMonthView.Range("basket").Resize(1, 1).Offset(i - 2, 15).Value = basket(i, 4)
|
||||
Next i
|
||||
|
||||
busy = False
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub basket_pick(ByRef Target As Range)
|
||||
Dim i As Long
|
||||
With shMonthView
|
||||
build.Initialize .Cells(Target.row, 2), rev_cust(.Cells(Target.row, 6)), rev_cust(.Cells(Target.row, 12))
|
||||
build.Show
|
||||
|
||||
If build.useval Then
|
||||
busy = True
|
||||
|
||||
.Cells(Target.row + i, 2) = build.cbPart.Value
|
||||
.Cells(Target.row + i, 6) = rev_cust(build.cbBill.Value)
|
||||
.Cells(Target.row + i, 12) = rev_cust(build.cbShip.Value)
|
||||
busy = False
|
||||
GetEditBasket Selection
|
||||
|
||||
End If
|
||||
End With
|
||||
Target.Select
|
||||
End Sub
|
||||
|
||||
Private Function RemoveEmptyBasketLines() As Boolean
|
||||
If busy Then Exit Function
|
||||
busy = True
|
||||
|
||||
RemoveEmptyBasketLines = False
|
||||
Application.ScreenUpdating = False
|
||||
|
||||
Dim lastRow As Long
|
||||
lastRow = shMonthView.UsedRange.row + shMonthView.UsedRange.Rows.Count - 1
|
||||
|
||||
Dim i As Long
|
||||
For i = lastRow To shMonthView.Range("basket").row Step -1
|
||||
If WorksheetFunction.CountA(shMonthView.Cells(i, 1).EntireRow) = 0 Then
|
||||
shMonthView.Cells(i, 1).EntireRow.Delete
|
||||
RemoveEmptyBasketLines = True
|
||||
End If
|
||||
Next
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
|
||||
busy = False
|
||||
End Function
|
||||
|
||||
Private Sub GetEditBasket(touchedCells As Range)
|
||||
Dim i As Long
|
||||
Dim mix As Double
|
||||
Dim touch_mix As Double
|
||||
Dim untouched As Long
|
||||
Dim touch() As Boolean
|
||||
Dim basket() As Variant
|
||||
|
||||
ReDim basket(0, 3)
|
||||
|
||||
i = WorksheetFunction.CountA(Range("basket").Resize(, 1))
|
||||
If i > 0 Then
|
||||
|
||||
ReDim basket(i - 1, 3)
|
||||
ReDim touch(i - 1)
|
||||
untouched = i
|
||||
|
||||
busy = True
|
||||
|
||||
With shMonthView.Range("basket")
|
||||
mix = 0
|
||||
For i = 1 To .Rows.Count
|
||||
basket(i - 1, 0) = .Cells(i, 1)
|
||||
basket(i - 1, 1) = .Cells(i, 5)
|
||||
basket(i - 1, 2) = .Cells(i, 11)
|
||||
basket(i - 1, 3) = .Cells(i, 16) * 1
|
||||
mix = mix + basket(i - 1, 3)
|
||||
If IntersectsWith(touchedCells, .Cells(i, 16)) Then
|
||||
touch_mix = touch_mix + basket(i - 1, 3)
|
||||
touch(i - 1) = True
|
||||
untouched = untouched - 1
|
||||
End If
|
||||
Next
|
||||
|
||||
'evaluate mix changes, force to 100, and update the sheet
|
||||
For i = 0 To UBound(basket, 1)
|
||||
If Not touch(i) Then
|
||||
If mix = touch_mix Then
|
||||
basket(i, 3) = (1 - mix) / untouched
|
||||
Else
|
||||
basket(i, 3) = basket(i, 3) + basket(i, 3) * (1 - mix) / (mix - touch_mix)
|
||||
End If
|
||||
.Cells(i + 1, 16) = basket(i, 3)
|
||||
End If
|
||||
Next i
|
||||
|
||||
End With
|
||||
|
||||
busy = False
|
||||
|
||||
shMonthUpdate.Range("U2:X5000").ClearContents
|
||||
Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True)
|
||||
|
||||
If Me.newpart Then
|
||||
BuildJson
|
||||
End If
|
||||
End If
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub post_adjust()
|
||||
Dim i As Long
|
||||
Dim msg As String
|
||||
|
||||
If Me.newpart Then
|
||||
If WorksheetFunction.CountA(shMonthView.Range("basket").Resize(, 1)) = 0 Then
|
||||
msg = "At least one row needs to be entered in the lower table. Use the New Business button or double-click in the blue row of the empty table."
|
||||
End If
|
||||
|
||||
If Abs(WorksheetFunction.Sum(shMonthView.Range("basket").Resize(, 1).Offset(0, 15)) - 1#) > 0.000001 Then
|
||||
msg = "The mix column in the lower table does not add up to 100%. Change (or even just retype) one, and the rest will adjust"
|
||||
End If
|
||||
|
||||
If WorksheetFunction.CountIf(shMonthView.Range("SalesFinal"), 0) = 12 And WorksheetFunction.CountIf(shMonthView.Range("SalesNewAdj"), 0) = 12 Then
|
||||
msg = "At least one month needs to have forecast data entered."
|
||||
End If
|
||||
Else
|
||||
If WorksheetFunction.CountA(shMonthUpdate.Range("P2:P13")) = 0 Then msg = "Make sure at least one month has Final values for Volume, Price, and Sales."
|
||||
End If
|
||||
|
||||
If IsEmpty(shMonthView.Range("MonthTag").Value) Then msg = "You need to specify a tag for this update."
|
||||
|
||||
If msg <> "" Then
|
||||
MsgBox msg, vbOKOnly Or vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim adjust As Object
|
||||
Dim jdoc As String
|
||||
|
||||
If Me.newpart Then
|
||||
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(2, 16))
|
||||
adjust("message") = shMonthView.Range("MonthComment").Value
|
||||
adjust("tag") = shMonthView.Range("MonthTag").Value
|
||||
jdoc = JsonConverter.ConvertToJson(adjust)
|
||||
If Not handler.request_adjust(jdoc, msg) Then
|
||||
MsgBox msg, vbOKOnly Or vbCritical, "Adjustment was not made."
|
||||
Exit Sub
|
||||
End If
|
||||
Else
|
||||
Dim allMsg As String
|
||||
For i = 2 To 13
|
||||
If shMonthUpdate.Cells(i, 16) <> "" Then
|
||||
Set adjust = JsonConverter.ParseJson(shMonthUpdate.Cells(i, 16))
|
||||
adjust("message") = shMonthView.Range("MonthComment").Value
|
||||
adjust("tag") = shMonthView.Range("MonthTag").Value
|
||||
jdoc = JsonConverter.ConvertToJson(adjust)
|
||||
If Not handler.request_adjust(jdoc, msg) Then
|
||||
Dim period As String
|
||||
period = Format(i - 1, "00") & " - " & Format(DateSerial(2000, (i - 1) + 5, 1), "mmm")
|
||||
allMsg = IIf(allMsg = "", "", vbNewLine) & period & ": " & msg
|
||||
End If
|
||||
End If
|
||||
Next i
|
||||
|
||||
If allMsg <> "" Then MsgBox allMsg, vbOKOnly Or vbCritical, "Problems Loading Adjustments"
|
||||
End If
|
||||
|
||||
shOrders.Select
|
||||
|
||||
End Sub
|
||||
|
||||
Sub build_new()
|
||||
|
||||
shConfig.Range("rebuild").Value = 1
|
||||
Dim i As Long
|
||||
Dim j As Long
|
||||
Dim basket() As Variant
|
||||
Dim m() As Variant
|
||||
|
||||
busy = True
|
||||
|
||||
m = shMonthUpdate.Range("A2:O13").FormulaR1C1
|
||||
|
||||
For i = 1 To UBound(m, 1)
|
||||
For j = 1 To UBound(m, 2)
|
||||
m(i, j) = 0
|
||||
Next j
|
||||
Next i
|
||||
|
||||
shMonthUpdate.Range("A2:O13") = m
|
||||
|
||||
shMonthUpdate.Range("U2:X1000").ClearContents
|
||||
shMonthUpdate.Range("Z2:AC1000").ClearContents
|
||||
shMonthUpdate.Range("R2:S1000").ClearContents
|
||||
LoadSheet
|
||||
|
||||
basket = Utils.SHTp_get_block(shMonthUpdate.Range("U1"))
|
||||
' shMonthView.Cells(32, 2) = basket(1, 1)
|
||||
' shMonthView.Cells(32, 6) = basket(1, 2)
|
||||
' shMonthView.Cells(32, 12) = basket(1, 3)
|
||||
' shMonthView.Cells(32, 17) = basket(1, 4)
|
||||
Call Me.print_basket
|
||||
|
||||
busy = False
|
||||
|
||||
End Sub
|
||||
|
||||
Sub new_part()
|
||||
|
||||
'keep customer mix
|
||||
'add in new part number
|
||||
'retain to _month
|
||||
'set new part flag
|
||||
|
||||
Dim cust() As String
|
||||
Dim i As Long
|
||||
|
||||
'---------build customer mix-------------------------------------------------------------------
|
||||
|
||||
cust = Utils.SHTp_Get(shMonthUpdate.Name, 1, 27, True)
|
||||
If Not Utils.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then
|
||||
MsgBox ("Error building customer mix.")
|
||||
End If
|
||||
|
||||
'--------inquire for new part to join with cust mix--------------------------------------------
|
||||
|
||||
part.Show
|
||||
|
||||
If Not part.useval Then
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
busy = True
|
||||
|
||||
With shMonthView.Range("basket")
|
||||
.ClearContents
|
||||
For i = 1 To UBound(cust, 2)
|
||||
.Cells(i, 1) = part.cbPart.Value
|
||||
.Cells(i, 5) = cust(0, i)
|
||||
.Cells(i, 11) = cust(1, i)
|
||||
.Cells(i, 16) = CDbl(cust(2, i))
|
||||
Next i
|
||||
End With
|
||||
|
||||
shConfig.Range("new_part").Value = 1
|
||||
|
||||
'------copy revised basket to _month storage---------------------------------------------------
|
||||
|
||||
With shMonthView.Range("basket")
|
||||
i = WorksheetFunction.CountA(.Resize(, 1))
|
||||
If i = 0 Then Exit Sub
|
||||
|
||||
ReDim basket(i - 1, 3)
|
||||
|
||||
For i = 1 To .Rows.Count
|
||||
basket(i - 1, 0) = .Cells(i, 1)
|
||||
basket(i - 1, 1) = .Cells(i, 5)
|
||||
basket(i - 1, 2) = .Cells(i, 11)
|
||||
basket(i - 1, 3) = .Cells(i, 16) * 1
|
||||
Next
|
||||
End With
|
||||
|
||||
shMonthUpdate.Range("U2:AC100000").ClearContents
|
||||
Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 21, False, False, True)
|
||||
Call Utils.SHTp_DumpVar(basket, shMonthUpdate.Name, 2, 26, False, False, True)
|
||||
|
||||
'------reset volume to copy base to forecsat and clear base------------------------------------
|
||||
|
||||
units = shMonthUpdate.Range("A2:E13").FormulaR1C1
|
||||
price = shMonthUpdate.Range("F2:J13").FormulaR1C1
|
||||
sales = shMonthUpdate.Range("K2:O13").FormulaR1C1
|
||||
tunits = shMonthView.Range("tunits")
|
||||
tprice = shMonthView.Range("tprice")
|
||||
tsales = shMonthView.Range("tsales")
|
||||
ReDim adjust(12)
|
||||
For i = 1 To 12
|
||||
'volume
|
||||
units(i, 5) = 0 'units(i, 2)
|
||||
units(i, 4) = 0 'units(i, 2)
|
||||
units(i, 1) = 0
|
||||
units(i, 2) = 0
|
||||
units(i, 3) = 0
|
||||
'sales
|
||||
sales(i, 5) = 0 'sales(i, 2)
|
||||
sales(i, 4) = 0 'sales(i, 2)
|
||||
sales(i, 1) = 0
|
||||
sales(i, 2) = 0
|
||||
sales(i, 3) = 0
|
||||
'price
|
||||
price(i, 5) = 0 'price(i, 2)
|
||||
price(i, 4) = 0 'price(i, 2)
|
||||
price(i, 1) = 0
|
||||
price(i, 2) = 0
|
||||
price(i, 3) = 0
|
||||
Next i
|
||||
CrunchArray
|
||||
BuildJson
|
||||
SetSheet
|
||||
|
||||
'-------------push revised arrays back to _month, not revertable-------------------------------
|
||||
|
||||
shMonthUpdate.Range("A2:E13") = units
|
||||
shMonthUpdate.Range("F2:J13") = price
|
||||
shMonthUpdate.Range("K2:o13") = sales
|
||||
|
||||
|
||||
'force basket to show to demonstrate the part was changed
|
||||
shConfig.Range("show_basket").Value = 1
|
||||
Call Me.print_basket
|
||||
busy = False
|
||||
|
||||
End Sub
|
||||
|
||||
Function newpart() As Boolean
|
||||
newpart = shConfig.Range("new_part").Value = 1
|
||||
End Function
|
||||
|
||||
Private Sub Worksheet_Deactivate()
|
||||
Forecasting.shMonthView.Visible = IIf(shConfig.Range("debug_mode").Value, xlSheetVisible, xlSheetHidden)
|
||||
End Sub
|
||||
114
Master Template.xlsm_EXPORTS/shOrders.cls
Normal file
114
Master Template.xlsm_EXPORTS/shOrders.cls
Normal file
@ -0,0 +1,114 @@
|
||||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "shOrders"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = True
|
||||
Option Explicit
|
||||
|
||||
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
|
||||
Dim pt As PivotTable
|
||||
Set pt = ActiveSheet.PivotTables("ptOrders")
|
||||
|
||||
Dim intersec As Range
|
||||
Set intersec = Intersect(Target, pt.DataBodyRange)
|
||||
|
||||
If intersec Is Nothing Then
|
||||
Exit Sub
|
||||
ElseIf intersec.address <> Target.address 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 pf As PivotField
|
||||
Dim pi As PivotItem
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
|
||||
9
Master Template.xlsm_EXPORTS/shSupportingData.cls
Normal file
9
Master Template.xlsm_EXPORTS/shSupportingData.cls
Normal 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
|
||||
114
Master Template.xlsm_EXPORTS/shWalk.cls
Normal file
114
Master Template.xlsm_EXPORTS/shWalk.cls
Normal file
@ -0,0 +1,114 @@
|
||||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "shWalk"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = True
|
||||
'Option Explicit
|
||||
'
|
||||
'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
|
||||
' Dim pt As PivotTable
|
||||
' Set pt = ActiveSheet.PivotTables("ptWalk")
|
||||
' Dim intersec As Range
|
||||
' Set intersec = Intersect(Target, pt.DataBodyRange)
|
||||
'
|
||||
' If intersec Is Nothing Then
|
||||
' Exit Sub
|
||||
' ElseIf intersec.address <> Target.address 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 pf As PivotField
|
||||
' Dim pi As PivotItem
|
||||
'
|
||||
' 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)
|
||||
'
|
||||
' 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
|
||||
'
|
||||
'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
|
||||
'
|
||||
'
|
||||
|
||||
Loading…
Reference in New Issue
Block a user