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

Compare commits

base: pt:4b6d0c744dbb2ecde27d18c418e9c618a161679c
Branches Tags
pt:master
..
compare: pt:f546f7c7d1c8b904e5ecb5aa41d5f585c2d167e0
Branches Tags
pt:master

No commits in common. "4b6d0c744dbb2ecde27d18c418e9c618a161679c" and "f546f7c7d1c8b904e5ecb5aa41d5f585c2d167e0" have entirely different histories.
4b6d0c744d ... f546f7c7d1

21 changed files with 3041 additions and 7736 deletions
Show Stats Expand all files Collapse all files

414
FL.bas
View File

@ -1,30 +1,17 @@
Attribute VB_Name = "FL"
Option Explicit
Public price_sheet As Worksheet
Public x As New TheBigOne
Public Enum ColorTier
B_ase = 0
T_raditional = 1
principa_L = 2
pre_M_ium = 3
P_rogram = 4
C_ustom = 5
E_cogrow = 6
O_rganic = 7
W_axtough = 8
End Enum
Public x As New TheBigOne
Sub Determine_Active_Range()
Dim r As Range
Dim r As range
Dim s As String
Dim cell As Range
Dim cell As range
Set r = Selection
MsgBox (r.address)
MsgBox (r.Address)
For Each cell In r.Cells
s = s & cell.value
@ -37,8 +24,8 @@ End Sub
Sub Cross_Join_Selection()
Dim x As New TheBigOne
Dim r As Range
Dim ar As Range
Dim r As range
Dim ar As range
Dim r1() As String
Dim r2() As String
Dim d() As String
@ -249,7 +236,7 @@ End Function
Sub add_quote_front()
Dim r As Range
Dim r As range
Set r = Selection
Dim c As Object
@ -260,13 +247,12 @@ Sub add_quote_front()
End Sub
Function json_from_list(keys As Range, values As Range) As String
Function json_from_list(keys As range, values As range) As String
Dim json As String
Dim i As Integer
Dim first_comma As Boolean
Dim needs_braces As Integer
Dim needs_comma As Boolean
needs_comma = False
needs_braces = 0
@ -290,13 +276,7 @@ Function json_from_list(keys As Range, values As Range) As String
End Function
Function json_nest(key As String, json As String) As String
json_nest = "{""" & key & """:" & json & "}"
End Function
Function json_concat(list As Range) As String
Function json_concat(list As range) As String
Dim json As String
Dim i As Integer
@ -326,7 +306,6 @@ Sub json_from_table_pretty()
Dim x As New TheBigOne
Dim tbl() As Variant
Selection.CurrentRegion.Select
tbl = Selection
Dim ajson As String
@ -378,7 +357,6 @@ Sub json_from_table()
Dim tbl() As Variant
Selection.CurrentRegion.Select
tbl = Selection
Call wapi.ClipBoard_SetData(x.json_from_table(tbl, "y", False))
@ -386,7 +364,6 @@ Sub json_from_table()
End Sub
Sub PastValues()
Attribute PastValues.VB_ProcData.VB_Invoke_Func = "V\n14"
On Error GoTo errh
@ -398,7 +375,6 @@ errh:
End Sub
Sub CollapsePvtItem()
Attribute CollapsePvtItem.VB_ProcData.VB_Invoke_Func = "Z\n14"
On Error GoTo show_det
ActiveCell.PivotItem.DrilledDown = False
@ -426,7 +402,6 @@ errh:
End Sub
Sub ExpandPvtItem()
Attribute ExpandPvtItem.VB_ProcData.VB_Invoke_Func = "X\n14"
On Error GoTo show_det
ActiveCell.PivotItem.DrilledDown = True
@ -454,7 +429,6 @@ errh:
End Sub
Sub CollapsePvtFld()
Attribute CollapsePvtFld.VB_ProcData.VB_Invoke_Func = "A\n14"
On Error GoTo show_det
ActiveCell.PivotField.DrilledDown = False
@ -483,7 +457,6 @@ errh:
End Sub
Sub ExpandPvtFld()
Attribute ExpandPvtFld.VB_ProcData.VB_Invoke_Func = "S\n14"
On Error GoTo show_det
ActiveCell.PivotField.DrilledDown = True
@ -582,7 +555,6 @@ Sub markdown_from_table()
Dim wapi As New Windows_API
Dim tbl() As Variant
Selection.CurrentRegion.Select
tbl = Selection
Call wapi.ClipBoard_SetData(x.markdown_from_table(tbl))
@ -612,43 +584,13 @@ Sub markdown_whole_sheet()
End Sub
Sub sql_from_range_db2_qh()
Sub sql_from_range()
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r() As String
Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, True))
End Sub
Sub sql_from_range_db2_noqh()
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r() As String
Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, False))
End Sub
Sub sql_from_range_pg_qh()
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r() As String
Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, True))
End Sub
Sub sql_from_range_pg_noqh()
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r() As String
Selection.CurrentRegion.Select
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False))
Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2))
End Sub
@ -659,7 +601,6 @@ Sub auto_fit_range()
End Sub
Sub pivot_field_format()
Attribute pivot_field_format.VB_ProcData.VB_Invoke_Func = "F\n14"
ActiveSheet.PivotTables(1).PivotFields(ActiveCell.value).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
@ -731,337 +672,4 @@ Sub split_forecast_data()
End Sub
Function range_empty(ByRef r As Range) As Boolean
Dim c As Range
range_empty = True
For Each c In r.Cells
If Not IsEmpty(c.value) Then
range_empty = False
Exit Function
End If
Next c
End Function
Function build_monthly(ByRef part As String, billto_group As String, month As String, vol As Double, amt As Double) As String
Dim j As Object
Set j("part") = part
Set j("billto_group") = billto_group
Set j("month") = month
Set j("part") = vol
Set j("part") = amt
build_monthly = JsonConverter.ConvertToJson(j)
End Function
Sub extract_price_matrix()
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl() As Variant
Dim unp() As String
Dim unps() As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim cms_pl() As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
'------------------------------------selection-------------------------------------------------
Set orig = Application.Selection
Selection.CurrentRegion.Select
Set orig = Application.Selection
'--------------------------------test if valid price matrix------------------------------
If Selection.Cells.Count = 1 Then
MsgBox ("selection is not a table")
orig.Select
Exit Sub
End If
tbl = Selection
If UBound(tbl, 1) < 4 Then error = "selection is not a valid price matrix"
If UBound(tbl, 2) < 2 Then error = "selection is not a valid price matrix"
If Not error = "" Then
MsgBox (error)
Exit Sub
End If
'-----------------------------unpivot price matrix into new array-----------------------------
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
ReDim unp(8, (UBound(tbl, 2) - 1) * (UBound(tbl, 1) - 4))
For i = 5 To UBound(tbl, 1)
For j = 2 To UBound(tbl, 2)
k = k + 1
'part
unp(0, k) = tbl(i, 1)
'copy headers down the left
unp(1, k) = tbl(1, j) 'color code/tier (row one, column j)
unp(2, k) = tbl(2, j) 'size code (row two, column j)
unp(3, k) = tbl(3, j) 'volue break uom (row 3, column j)
unp(4, k) = Format(tbl(4, j), "#.00") 'volue break qty (row 4, column j)
unp(5, k) = "M" 'pricing unit of measuer
unp(6, k) = Format(tbl(i, j), "#.00") 'price (row i, column j)
unp(7, k) = i
unp(8, k) = j
Next j
Next i
unp(0, 0) = "mold"
unp(1, 0) = "sizc"
unp(2, 0) = "color"
unp(3, 0) = "vbuom"
unp(4, 0) = "vbqty"
unp(5, 0) = "puom"
unp(6, 0) = "price"
unp(7, 0) = "orig_row"
unp(8, 0) = "orig_col"
If Not x.TBLp_TestNumeric(unp, 4) Then
MsgBox ("volume break quantity is text")
Exit Sub
End If
If Not x.TBLp_TestNumeric(unp, 6) Then
MsgBox ("price is text")
Exit Sub
End If
'-------------------------prepare sql to upload---------------------------------------------------------------
sql = x.SQLp_build_sql_values(unp, False, True, Db2, False)
sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA"
Call wapi.ClipBoard_SetData(sql)
If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then
MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
Exit Sub
End If
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Call x.ADOp_CloseCon(0)
Exit Sub
End If
'-------------------call price build procedure--------------------------------------------------------
cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True)
Call x.ADOp_CloseCon(0)
If x.ADOo_errstring <> "" Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
'--------------------------setup an output sheet if necessary-------------------------------
For Each ws In Application.Worksheets
For Each cp In ws.CustomProperties
If cp.Name = "spec_name" And cp.value = "price_list" Then
Set new_sh = ws
End If
Next cp
Next ws
If new_sh Is Nothing Then
Set new_sh = Application.Worksheets.Add
Call new_sh.CustomProperties.Add("spec_name", "price_list")
End If
'-------------------------dump contents------------------------------------------------------
Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True)
new_sh.Select
ActiveSheet.Cells(1, 1).CurrentRegion.Select
Selection.Columns.AutoFit
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'--------------------------format source cells for any build issues--------------------------------
orig.Worksheet.Select
With orig.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For i = 1 To UBound(cms_pl, 1)
Select Case cms_pl(i, 13)
Case ""
Case "no unit conversion"
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
Case "no part number"
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
End Select
Next i
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
End Sub
Sub go_to_price_issue()
Dim ws As Worksheet
Dim cp As CustomProperty
Dim orig As Range
Dim trow As Long
Dim tcol As Long
Dim i As Long
Dim has_Pricesheet As Boolean
has_Pricesheet = False
For Each ws In Application.Worksheets
For Each cp In ws.CustomProperties
If cp.Name = "spec_name" And cp.value = "price_list" Then
Set price_sheet = ws
has_Pricesheet = True
End If
Next cp
Next ws
If Not has_Pricesheet Then
MsgBox ("no price sheet found")
Exit Sub
End If
Set orig = Application.Selection
Selection.CurrentRegion.Select
trow = orig.row - Selection.row + 1
tcol = orig.column - Selection.column + 1
orig.Select
i = 1
Do Until price_sheet.Cells(i, 1) = ""
If price_sheet.Cells(i, 15) = trow And price_sheet.Cells(i, 16) = tcol And price_sheet.Cells(i, 14) <> "" Then
price_sheet.Select
ActiveSheet.Cells(i, 14).Select
Exit Sub
End If
i = i + 1
Loop
End Sub
Sub build_price_upload()
Dim x As New TheBigOne
Dim pl() As String
Dim i As Long
Dim j As Long
Dim ul() As String
Dim pl_code As String
Dim pl_action As String
Dim pl_d1 As String
Dim pl_d2 As String
Dim pl_d3 As String
Dim fd As FileDialog
pl = x.SHTp_GetString(Selection)
ReDim ul(11, UBound(pl, 2))
PRICELIST_SHOW:
pricelist.Show
pl_code = pricelist.tbCODE.Text
pl_d1 = pricelist.tbD1.Text
pl_d2 = pricelist.tbD2.Text
pl_d3 = pricelist.tbD3.Text
pl_action = "1"
If Len(pricelist.tbCODE) > 5 Then
MsgBox ("price code must be 5 or less characters")
GoTo PRICELIST_SHOW
End If
If Not pricelist.cbInactive Then
Call x.TBLp_FilterSingle(pl, 11, "I", False)
End If
If Not pricelist.cbNonStocked Then
Call x.TBLp_FilterSingle(pl, 10, "A", True)
End If
ul(0, 0) = "HDR"
ul(1, 0) = pl_action
ul(2, 0) = pl_code
ul(3, 0) = Left(pl_d1, 30)
ul(4, 0) = Left(pl_d2, 30)
ul(5, 0) = Left(pl_d3, 30)
ul(6, 0) = "Y"
ul(7, 0) = "N"
j = 0
For i = LBound(pl, 2) + 1 To UBound(pl, 2)
'if there is no [uom, part#, price], don't create a row
If pl(12, i) <> "" And pl(13, i) <> "" And pl(8, i) <> "" And pl(9, i) <> "" Then
j = j + 1
ul(0, j) = "DTL" 'DTL
ul(1, j) = pl_code 'Price list code
ul(2, j) = pl(9, i) 'part number
ul(3, j) = pl(7, i) 'price unit
ul(4, j) = Format(CDbl(pl(6, i)) * CDbl(pl(12, i)) / CDbl(pl(13, i)), "0.00") 'volume break in price uom
ul(5, j) = Format(pl(8, i), "0.00") 'price
ul(11, j) = "1" 'add, update, delete
End If
Next i
ReDim Preserve ul(11, j)
'--------Open file-------------
If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & pl_code & ".csv", ul) Then
MsgBox ("error")
End If
Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & pl_code & ".csv")
'---------------------header row---------------------------------
End Sub

1125
JsonConverter.bas
View File

File diff suppressed because it is too large Load Diff

312
TheBigOne.cls
View File

@ -1,13 +1,3 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "TheBigOne"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private ADOo_con() As ADODB.Connection
@ -17,7 +7,7 @@ Public ADOo_errstring As String
Public Enum ADOinterface
MicrosoftJetOLEDB4 = 0
MicrosoftACEOLEDB12 = 1
SqlServer = 2
SQLServer = 2
SQLServerNativeClient = 3
SQLServerNativeClient10 = 4
OracleODBC = 5
@ -29,13 +19,11 @@ End Enum
Public Enum SQLsyntax
Db2 = 0
SqlServer = 1
SQLServer = 1
PostgreSQL = 2
End Enum
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
@ -399,7 +387,7 @@ Sub SHTp_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, B
If clear Then sh.Cells.clear
If transpose Then Call Me.ARRAYp_Transpose(tbl)
sh.Range(sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address).FormulaR1C1 = tbl
sh.range(sh.Cells(row, col).Address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).Address).FormulaR1C1 = tbl
On Error GoTo errhndl
@ -415,30 +403,6 @@ errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
End Sub
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 Me.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
Sub ARRAYp_Transpose(ByRef a() As String)
@ -500,19 +464,19 @@ errhdnl:
End Function
Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVal Filter As String, ByVal Equals As Boolean)
Dim i As Long
Dim j As Long
Dim m As Long
j = LBound(table, 2)
i = LBound(table, 2) + 1
j = 0
i = 1
While i <= UBound(table, 2)
If (table(column, i) = Filter) = Equals Then
j = j + 1
m = LBound(table, 1)
m = 0
While m <= UBound(table, 1)
table(m, j) = table(m, i)
m = m + 1
@ -521,7 +485,7 @@ Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVa
i = i + 1
Wend
ReDim Preserve table(LBound(table, 1) To UBound(table, 1), LBound(table, 2) To j)
ReDim Preserve table(UBound(table, 1), j)
End Sub
@ -581,21 +545,21 @@ Sub TBLp_DeleteCols(ByRef tbl() As String, ByRef column() As Integer)
Dim j As Long
Dim m As Long
Dim k As Long
Dim ok As Boolean
Dim OK As Boolean
m = -1
i = 0
While i <= UBound(tbl, 1)
k = 0
ok = True
OK = True
Do While k <= UBound(column())
If i = column(k) Then
ok = False
OK = False
Exit Do
End If
k = k + 1
Loop
If ok = True Then
If OK = True Then
m = m + 1
j = 0
While j <= UBound(tbl, 2)
@ -1328,7 +1292,7 @@ Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As
End Function
Public Function ROWe_FindOnSorted(ByRef tbl() As String, ByRef Range As Long, ByRef match As Boolean, ParamArray fldsvals()) As Long
Public Function ROWe_FindOnSorted(ByRef tbl() As String, ByRef range As Long, ByRef match As Boolean, ParamArray fldsvals()) As Long
On Error GoTo errpath
'has to be a lexicographically sorted table otherwise this evaluaiton will not be the same as the sort evaluaiton
@ -1398,7 +1362,7 @@ Public Function ROWe_FindOnSorted(ByRef tbl() As String, ByRef Range As Long, By
j = currow
End If
Range = i
range = i
ROWe_FindOnSorted = j
match = True
Exit Function
@ -1465,7 +1429,7 @@ Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITL
MsgB.Caption = TITLE
MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
MsgB.Show
MISC_msgbox_cancel = MsgB.cancel
MISC_msgbox_cancel = MsgB.Cancel
Application.EnableCancelKey = xlInterrupt
End Function
@ -1621,7 +1585,7 @@ Sub SHTp_HyperlinkConvert(ByRef sheet As Worksheet, ByRef column As Integer, ByR
Set sh = sheet
i = startrow
Do Until sh.Cells(i, column) = stopflag
Call sh.Hyperlinks.Add(sh.Range(sh.Cells(i, column).address), sh.Cells(i, column))
Call sh.Hyperlinks.Add(sh.range(sh.Cells(i, column).Address), sh.Cells(i, column))
i = i + 1
Loop
@ -1669,8 +1633,7 @@ Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolea
tsf.Type = 2
'tsf.Charset = "utf-8"
tsf.Charset = "Windows-1252"
tsf.Charset = "utf-8"
tsf.Open
'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
@ -1680,10 +1643,10 @@ Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolea
For j = 0 To UBound(recs, 1)
If j = 0 Then
test_empty = Replace(Replace(recs(j, i), ",", ""), """", "")
wl = Replace(Replace(recs(j, i), ",", ""), """", "")
wl = """" & Replace(Replace(recs(j, i), ",", ""), """", "") & """"
Else
test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "")
wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "")
wl = wl & ",""" & Replace(Replace(recs(j, i), ",", ""), """", "") & """"
End If
Next j
If Len(test_empty) > 0 Then
@ -1985,7 +1948,7 @@ Function TXTp_ParseCSVrow(ByRef csv() As String, row As Long, col As Integer) As
End Function
Function json_from_list(keys As Range, values As Range) As String
Function json_from_list(keys As range, values As range) As String
Dim json As String
Dim i As Integer
@ -2014,7 +1977,7 @@ Function json_from_list(keys As Range, values As Range) As String
End Function
Function json_concat(list As Range) As String
Function json_concat(list As range) As String
Dim json As String
Dim i As Integer
@ -2037,7 +2000,7 @@ Function json_concat(list As Range) As String
End Function
Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String
Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, Target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String
Dim i As Long
@ -2045,7 +2008,7 @@ Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, target As String, tri
Dim sql As String
Dim rec As String
sql = "INSERT INTO " & target & " VALUES " & vbCrLf
sql = "INSERT INTO " & Target & " VALUES " & vbCrLf
For i = start To ending
rec = ""
If i <> start Then sql = sql & "," & vbCrLf
@ -2170,7 +2133,7 @@ Public Function MISCe_MaxLng(ByRef base As Long, ByRef compare As Long) As Long
End Function
Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_format As String) As String
Public Function markdown_from_table(ByRef tbl() As Variant) As String
@ -2191,7 +2154,6 @@ Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_form
'---build markdown table-----------
For r = 1 To UBound(tbl, 1)
If r = 2 Then
'If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
md = md & "|"
For c = 1 To UBound(tbl, 2)
md = md & "---" & String(Me.MISCe_MaxInt(msl(c), 3) - 3, "-") & "|"
@ -2209,10 +2171,9 @@ Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_form
End Function
Public Function json_multirange(ByRef r As range) As String
Public Function json_multirange(ByRef r As Range) As String
Dim ar As Range
Dim ar As range
Dim r1() As Variant
Dim r2() As Variant
Dim rslt As String
@ -2246,7 +2207,7 @@ Function markdown_whole_sheet(ByRef sh As Worksheet) As String
Dim x As New TheBigOne
Dim tbl() As Variant
tbl = sh.Range("A1:CZ1000").FormulaR1C1
tbl = sh.range("A1:CZ1000").FormulaR1C1
For ic = 1 To UBound(tbl, 2)
For ir = 1 To UBound(tbl, 1)
@ -2257,13 +2218,13 @@ Function markdown_whole_sheet(ByRef sh As Worksheet) As String
Next ir
Next ic
tbl = sh.Range(sh.Cells(1, 1).address & ":" & sh.Cells(mr, mc).address).FormulaR1C1
tbl = sh.range(sh.Cells(1, 1).Address & ":" & sh.Cells(mr, mc).Address).FormulaR1C1
markdown_whole_sheet = Me.markdown_from_table(tbl)
End Function
Function MISCe_col_to_letter(ByRef x As Long) As String
Function MISCe_colnum_to_letter(ByRef x As Long) As String
If x > 26 Then
MISCe_colnum_to_letter = Chr(x \ 26 + 64) & Chr((x / 26 - x \ 26) * 26 + 64)
@ -2273,8 +2234,7 @@ Function MISCe_col_to_letter(ByRef x As Long) As String
End Function
Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax, ByRef quote_headers As Boolean) As String
Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax) As String
Dim i As Long
@ -2284,17 +2244,6 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
Dim type_flag() As String
Dim col_name As String
Dim start_row As Long
Dim rx As Object
Dim strip_text As String
Dim strip_num As String
Dim strip_date As String
Set rx = CreateObject("vbscript.regexp")
rx.Global = True
strip_text = "[^a-zA-Z0-9 \-\_\,\#\""]"
strip_num = "[^0-9\.]"
strip_date = "[^0-9\\\-\:\.]"
ReDim type_flag(UBound(tbl, 1))
For j = 0 To UBound(tbl, 1)
@ -2317,22 +2266,16 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
End If
Next j
rx.Pattern = strip_text
If headers Then
start_row = 1
For i = 0 To UBound(tbl, 1)
If i > 0 Then col_name = col_name & ","
If quote_headers Then
col_name = col_name & """" & rx.Replace(tbl(i, 0), "") & """"
Else
col_name = col_name & rx.Replace(tbl(i, 0), "")
End If
col_name = col_name & """" & tbl(i, 0) & """"
Next i
Else
start_row = 0
End If
For i = start_row To UBound(tbl, 2)
rec = ""
If i <> start_row Then sql = sql & "," & vbCrLf
@ -2341,40 +2284,35 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
If j <> 0 Then rec = rec & ","
Select Case type_flag(j)
Case "N" '-------N = numeric but should probably be N for numeric----
rx.Pattern = strip_num
If tbl(j, i) = "" Then
rec = rec & "CAST(NULL AS NUMERIC)"
Else
rec = rec & rx.Replace(tbl(j, i), "")
rec = rec & Replace(Replace(tbl(j, i), "'", "''"), ",", "")
End If
Case "S" '-------S = string------------------------------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS VARCHAR(255))"
Else
If trim Then
rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'"
rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'"
Else
rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'"
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'"
End If
End If
Case "D" '-------D = date---------------------------------------------
rx.Pattern = strip_date
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS DATE)"
Else
rec = rec & "CAST('" & rx.Replace(tbl(j, i), "") & "' AS DATE)"
rec = rec & "CAST('" & tbl(j, i) & "' AS DATE)"
End If
Case Else '-------Assume text------------------------------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS VARCHAR(255))"
Else
If trim Then
rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'"
rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'"
Else
rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'"
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'"
End If
End If
End Select
@ -2386,7 +2324,7 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
Select Case syntax
Case SQLsyntax.Db2
sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.SqlServer
Case SQLsyntax.SQLServer
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.PostgreSQL
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
@ -2398,7 +2336,7 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
End Function
Public Function ARRAYp_get_range_string(ByRef r As Range) As String()
Public Function ARRAYp_get_range_string(ByRef r As range) As String()
Dim i As Long
Dim j As Long
@ -2425,176 +2363,4 @@ Public Function ARRAYp_get_range_string(ByRef r As Range) As String()
End Function
Public Function TBLp_range(ByRef dump() As Variant, ByVal upperleft As Range) As Range
Dim width As Long
width = UBound(dump, 2)
Dim newcol As String
newcol = ConvertBase10(upperleft.column + UBound(dump, 2), "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function
Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As String) As String
'credit: http://www.freevbcode.com/ShowCode.asp?ID=6604
Dim s As String, tmp As Double, i As Integer, lastI As Integer
Dim BaseSize As Integer
BaseSize = Len(sNewBaseDigits)
Do While Val(d) <> 0
tmp = d
i = 0
Do While tmp >= BaseSize
i = i + 1
tmp = tmp / BaseSize
Loop
If i <> lastI - 1 And lastI <> 0 Then s = s & String(lastI - i - 1, Left(sNewBaseDigits, 1)) 'get the zero digits inside the number
tmp = Int(tmp) 'truncate decimals
s = s + Mid(sNewBaseDigits, tmp + 1, 1)
d = d - tmp * (BaseSize ^ i)
lastI = i
Loop
s = s & String(i, Left(sNewBaseDigits, 1)) 'get the zero digits at the end of the number
Misc_ConvBase10 = s
End Function
Public Function SHTp_get_block(point As Range) As Variant()
' Dim left As Long
' Dim right As Long
' Dim top As Long
' Dim bot As Long
' Dim i As Long
' Dim lcol As String
' Dim rcol As String
' Dim r As Range
'
'
' i = 0
' Do Until point.Worksheet.Cells(point.row, point.column + i) = ""
' i = i + 1
' Loop
' If i <> 0 Then i = i - 1
' right = point.column + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row, point.column + i) = ""
' i = i - 1
' Loop
' If i <> 0 Then i = i + 1
' left = point.column + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row + i, point.column) = ""
' i = i + 1
' Loop
' If i <> 0 Then i = i - 1
' bot = point.row + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row + i, point.column) = ""
' i = i - 1
' If point.row + i < 1 Then Exit Do
' Loop
' If i <> 0 Then i = i + 1
' top = point.row + i
'
' lcol = Me.ColumnLetter(left)
' rcol = Me.ColumnLetter(right)
'point.row (right)
SHTp_get_block = point.CurrentRegion
End Function
Public Function SHTp_GetString(point As Range) As String()
Dim x() As String
Dim pl() As Variant
pl = point.CurrentRegion
SHTp_GetString = Me.TBLp_Transpose(Me.TBLp_VarToString(pl))
End Function
Function ColumnLetter(ColumnNumber As Long) As String
Dim n As Long
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
End Function
Function TBLp_TestNumeric(ByRef table() As String, ByRef column As Long) As Boolean
Dim i As Long
Dim j As Long
Dim m As Long
TBLp_TestNumeric = True
j = 0
i = 1
For i = 1 To UBound(table, 2)
If Not IsNumeric(table(column, i)) And table(column, i) <> "" Then
TBLp_TestNumeric = False
Exit Function
End If
Next i
End Function
Function TBLp_Transpose(ByRef t() As String) As String()
Dim i As Long
Dim j As Long
Dim x() As String
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
For i = 1 To UBound(t, 2)
For j = 1 To UBound(t, 1)
x(i, j) = t(j, i)
Next j
Next i
TBLp_Transpose = x
End Function
Function TBLp_VarToString(ByRef t() As Variant) As String()
Dim i As Long
Dim j As Long
Dim x() As String
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2))
For i = LBound(t, 1) To UBound(t, 1)
For j = LBound(t, 2) To UBound(t, 2)
x(i, j) = t(i, j)
Next j
Next i
TBLp_VarToString = x
End Function

78
build.frm
View File

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

BIN
build.frx
View File

Binary file not shown.

53
changes.frm
View File

@ -1,53 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes
Caption = "History"
ClientHeight = 7740
ClientLeft = 120
ClientTop = 465
ClientWidth = 16260
OleObjectBlob = "changes.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "changes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private x As Variant
Private Sub cbCancel_Click()
Me.Hide
End Sub
Private Sub 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, 4)
Exit Sub
End If
Next i
End Sub
Private Sub UserForm_Activate()
Dim fail As Boolean
x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
If fail Then
Me.Hide
Exit Sub
End If
Me.lbHist.list = x
End Sub

BIN
changes.frx
View File

Binary file not shown.

929
fpvt.frm
View File

@ -1,929 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
Caption = "Forecast Adjustment"
ClientHeight = 7350
ClientLeft = 120
ClientTop = 465
ClientWidth = 7110
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
Public mod_adjust As Boolean
Private month() As Variant
Private mload() As Variant
Private adjust As Object
Private nomonth As Boolean
Private mline As Integer
Private clear_lb As Boolean
Private load_tb As Boolean
Private set_Price As Boolean
Private sp As Object
Private basket() As Variant
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
Private bVolm As Double
Private bValm As Double
Private bPrcm As Double
Private pVolm As Double
Private pValm As Double
Private pPrcm As Double
Private aVolm As Double
Private aValm As Double
Private aPrcm As Double
Private fVolm As Double
Private fValm As Double
Private fPrcm As Double
Option Explicit
Private Sub cbCancel_Click()
tbAdjVol.value = 0
tbAdjVal.value = 0
tbAdjPrice.value = 0
fpvt.Hide
End Sub
Private Sub butAdjust_Click()
Dim fail As Boolean
Call handler.request_adjust(JsonConverter.ConvertToJson(adjust), fail)
If fail Then
MsgBox ("adjustment was not made due to error")
Exit Sub
End If
Me.Hide
Set adjust = Nothing
End Sub
Private Sub butCancel_Click()
Me.Hide
End Sub
Private Sub butMAdjust_Click()
Dim i As Integer
For i = 1 To 12
If month(i, 10) <> "" Then
Call handler.request_adjust(CStr(month(i, 10)))
End If
Next i
Me.Hide
End Sub
Private Sub butMCancel_Click()
Me.Hide
End Sub
Private Sub cbGoSheet_Click()
Me.Hide
Worksheets("month").Visible = xlSheetVisible
Sheets("month").Select
End Sub
Private Sub lbMonth_Change()
If clear_lb Or load_tb Then Exit Sub
Dim i As Long
For i = 0 To 13
If lbMonth.Selected(i) Then
mline = i
If i <> 0 And i <> 13 Then
Me.load_var
Me.load_mbox
Else
load_tb = True
tbMBaseVal.value = ""
tbMBaseVol.value = ""
tbMBasePrice.value = ""
tbmPAVal.value = ""
tbMPAVol.value = ""
tbMPAPrice.value = ""
tbMFVal.value = ""
tbMFVol.value = ""
tbMFPrice.value = ""
tbMAVal.value = ""
tbMAVol.value = ""
tbMAPrice.value = ""
load_tb = False
End If
Exit For
End If
Next i
End Sub
Private Sub lheader_Click()
End Sub
Private Sub opEditPrice_Click()
opPlugVol.Enabled = False
opPlugPrice.Enabled = False
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
End Sub
Private Sub opEditSales_Click()
opPlugVol.Enabled = True
opPlugPrice.Enabled = True
opPlugVol.Visible = True
opPlugPrice.Visible = True
tbFcPrice.Enabled = False
tbFcPrice.BackColor = &H80000005
tbFcVal.Enabled = True
tbFcVal.BackColor = &H80000018
tbFcVol.Enabled = False
tbFcVol.BackColor = &H80000005
End Sub
Private Sub opEditPriceM_Click()
opmvol.Enabled = False
opmprice.Enabled = False
opmvol.Visible = False
opmprice.Visible = False
opmprice.value = True
opmvol.value = True
tbMFPrice.Enabled = True
tbMFPrice.BackColor = &H80000018
tbMFVal.Enabled = False
tbMFVal.BackColor = &H80000005
tbMFVol.Enabled = True
tbMFVol.BackColor = &H80000018
End Sub
Private Sub opEditSalesM_Click()
opmvol.Enabled = True
opmprice.Enabled = True
opmvol.Visible = True
opmprice.Visible = True
tbMFPrice.Enabled = False
tbMFPrice.BackColor = &H80000005
tbMFVal.Enabled = True
tbMFVal.BackColor = &H80000018
tbMFVol.Enabled = False
tbMFVol.BackColor = &H80000005
End Sub
Private Sub opEditVolM_Click()
opmvol.Enabled = False
opmprice.Enabled = False
opmprice.value = False
opmvol.value = True
opmvol.Enabled = False
opmprice.Enabled = False
opmvol.Visible = False
opmprice.Visible = False
tbMFPrice.Enabled = False
tbMFPrice.BackColor = &H80000005
tbMFVal.Enabled = False
tbMFVal.BackColor = &H80000005
tbMFVol.Enabled = True
tbMFVol.BackColor = &H80000018
End Sub
Private Sub opPlugPrice_Click()
calc_val
End Sub
Private Sub opPlugVol_Click()
calc_val
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
'--------------------------------monthly buttons--------------------------------------
Private Sub opmPrice_Click()
calc_mval
End Sub
Private Sub opmVol_Click()
calc_mval
End Sub
Private Sub tbmfPrice_Change()
If mline = 0 Then Exit Sub
If clear_lb Or load_tb Then Exit Sub
set_Price = True
If opEditPriceM Then calc_mprice
set_Price = False
End Sub
Private Sub tbMFVal_Change()
If mline = 0 Then Exit Sub
If clear_lb Or load_tb Then Exit Sub
If opEditSalesM Then calc_mval
End Sub
Private Sub tbmfVol_Change()
If mline = 0 Then Exit Sub
If clear_lb Or load_tb Then Exit Sub
If opEditPriceM Then calc_mprice
End Sub
Private Sub UserForm_Activate()
Dim i As Long
Dim j As Long
Dim k As Long
Dim ok As Boolean
Me.Caption = "Forecast Adjust " & Worksheets("config").Cells(8, 2)
Me.mp.Visible = False
Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
Me.lheader = "Ready"
If Not ok Then
fpvt.Hide
Application.StatusBar = False
Exit Sub
End If
'---show existing adjustment if there is one----
fpvt.mod_adjust = False
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
fpvt.Hide
Application.StatusBar = False
Exit Sub
End If
For i = 1 To sp("package")("totals").Count
Select Case sp("package")("totals")(i)("order_season")
Case 2020
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-------------------------------------------------------
k = 0
'--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)("2019 qty")
month(i, 2) = sp("package")("mpvt")(i)("2020 base qty")
month(i, 3) = sp("package")("mpvt")(i)("2020 adj qty")
month(i, 4) = sp("package")("mpvt")(i)("2020 tot qty")
month(i, 5) = sp("package")("mpvt")(i)("2019 value_usd")
month(i, 6) = sp("package")("mpvt")(i)("2020 base value_usd")
month(i, 7) = sp("package")("mpvt")(i)("2020 adj value_usd")
month(i, 8) = sp("package")("mpvt")(i)("2020 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
month(0, 0) = "month"
month(13, 0) = "total"
month(0, 1) = "2019 qty"
month(0, 2) = "2020 base qty"
month(0, 3) = "2020 adj qty"
month(0, 4) = "2020 qty"
month(0, 5) = "2019 val"
month(0, 6) = "2020 base val"
month(0, 7) = "2020 adj val"
month(0, 8) = "2020 val"
Me.crunch_array
ReDim basket(sp("package")("basket").Count, 3)
' basket(0, 0) = "order_season"
' basket(0, 1) = "order_month"
' basket(0, 2) = "version"
' basket(0, 3) = "iter"
' basket(0, 4) = "part_descr"
' basket(0, 5) = "bill_cust_descr"
' basket(0, 6) = "ship_cust_descr"
' basket(0, 7) = "units"
' basket(0, 8) = "value_usd"
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")("base")(i)("order_season")
'basket(i, 1) = sp("package")("base")(i)("order_month")
'basket(i, 2) = sp("package")("base")(i)("version")
'basket(i, 3) = sp("package")("base")(i)("iter")
'basket(i, 4) = sp("package")("base")(i)("part_descr")
'basket(i, 5) = sp("package")("base")(i)("bill_cust_descr")
'basket(i, 6) = sp("package")("base")(i)("ship_cust_descr")
'basket(i, 7) = sp("package")("base")(i)("units")
'basket(i, 8) = sp("package")("base")(i)("value_usd")
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
Call handler.month_tosheet(month, basket)
Application.StatusBar = False
Me.mp.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) = Format(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
'mline = 0
clear_lb = True
lbMonth.clear
lbMonth.list = mload
clear_lb = False
End Sub
Sub load_var()
'base
bVolm = co_num(month(mline, 2), 0)
bValm = co_num(month(mline, 6), 0)
'prior adjust
pVolm = co_num(month(mline, 3), 0)
pValm = co_num(month(mline, 7), 0)
'current forecast
fVolm = co_num(month(mline, 4), 0)
fValm = co_num(month(mline, 8), 0)
'adjustment
aVolm = fVolm - (bVolm + pVolm)
aValm = fValm - (bValm + pValm)
If month(mline, 9) = "addmonth" Then
nomonth = True
bPrcm = month(13, 6) / month(13, 2)
fPrcm = month(13, 8) / month(13, 4)
Else
'prices
If bVolm <> 0 Then bPrcm = bValm / bVolm
If (bVolm + pVolm) <> 0 Then pPrcm = (pValm + bValm) / (bVolm + pVolm) - bPrcm
If fVolm <> 0 Then fPrcm = fValm / fVolm
aPrcm = fPrcm - (bPrcm + pPrcm)
End If
End Sub
Sub load_mbox()
load_tb = True
tbMBaseVol = Format(bVolm, "#,###")
tbMBaseVal = Format(bValm, "#,###")
tbMBasePrice = Format(bPrcm, "0.000")
tbMPAVol = Format(pVolm, "#,###")
tbmPAVal = Format(pValm, "#,###")
tbMPAPrice = Format(pPrcm, "0.000")
tbMFVol = Format(fVolm, "#,###")
tbMFVal = Format(fValm, "#,###")
If Not set_Price Then tbMFPrice = Format(fPrcm, "0.###")
tbMAVol = Format(aVolm, "#,###")
tbMAVal = Format(aValm, "#,###")
tbMAPrice = Format(aPrcm, "0.000")
load_tb = False
End Sub
Sub load_mbox_ann()
load_tb = True
tbBaseVol = Format(bVol, "#,##0")
tbBaseVal = Format(bVal, "#,##0")
tbBasePrice = Format(bPrc, "0.000")
tbPadjVol = Format(pVol, "#,##0")
tbPadjVal = Format(pVal, "#,##0")
tbPadjPrice = Format(pPrc, "0.000")
tbFcVol = Format(fVol, "#,##0")
tbFcVal = Format(fVal, "#,##0")
If Not set_Price Then tbFcPrice = Format(fPrc, "0.000")
tbAdjVol = Format(aVol, "#,##0")
tbAdjVal = Format(aVal, "#,##0")
tbAdjPrice = Format(aPrc, "0.000")
load_tb = False
End Sub
Sub load_array()
'base
month(mline, 2) = bVolm
month(mline, 6) = bValm
'prior adjust
month(mline, 3) = pVolm
month(mline, 7) = pValm
'current forecast
month(mline, 4) = fVolm
month(mline, 8) = fValm
Me.crunch_array
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 ("a new part was added, and then adjusted to -0-")
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") = "b20"
adjust("scenario")("iter") = handler.basis
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
adjust("user") = Application.UserName
adjust("source") = "adj"
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()
'If IsNumeric(tbFcPrice.value) And tbFcPrice.value <> 0 And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then
'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then
'If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) Then
'capture currently changed item
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") = "b20"
adjust("scenario")("iter") = handler.basis
adjust("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
adjust("user") = Application.UserName
adjust("source") = "adj"
adjust("version") = "b20"
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
Sub calc_mval()
Dim pchange As Double
Dim j As Object
If IsNumeric(tbMFVal.value) Then
'get textbox value
fValm = tbMFVal.value
'do calculations
aValm = fValm - bValm - pValm
'---------if volume adjustment method is selected, scale the volume up----------------------------------
If nomonth Then
fVolm = fValm / bPrcm
fPrcm = bPrcm
Else
If opmvol Then
pchange = fValm / (pValm + bValm)
fVolm = (pVolm + bVolm) * pchange
Else
fVolm = pVolm + bVolm
End If
End If
If fVolm = 0 Then
fPrcm = 0
Else
fPrcm = fValm / fVolm
End If
aVolm = fVolm - (bVolm + pVolm)
aPrcm = fPrcm - (bPrcm + pPrcm)
Else
aVolm = fVolm - bVolm - pVolm
aPrcm = 0
End If
tbMFVal = Format(tbMFVal, "#,###")
'build json
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
j("scenario")("version") = "b20"
j("scenario")("iter") = handler.basis
j("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
j("user") = Application.UserName
j("source") = "adj"
If opEditSalesM Then
If opmvol Then
If nomonth Then
j("type") = "addmonth_v"
j("month") = month(mline, 0)
Else
j("type") = "scale_v"
j("scenario")("order_month") = month(mline, 0)
End If
j("amount") = aValm
Else
If nomonth Then
j("type") = "addmonth_p"
j("month") = month(mline, 0)
Else
j("type") = "scale_p"
j("scenario")("order_month") = month(mline, 0)
End If
j("amount") = aValm
End If
Else
If nomonth Then
j("type") = "addmonth_vp"
j("month") = month(mline, 0)
Else
j("type") = "scale_vp"
j("scenario")("order_month") = month(mline, 0)
End If
j("qty") = aVolm
j("amount") = aValm
End If
month(mline, 10) = JsonConverter.ConvertToJson(j)
tbAPI = JsonConverter.ConvertToJson(j)
Me.load_mbox
Me.load_array
End Sub
Sub calc_mprice()
Dim j As Object
If IsNumeric(tbMFPrice.value) And tbMFPrice.value <> 0 And IsNumeric(tbMFVol.value) And tbMFVol.value <> 0 Then
'capture currently changed item
fVolm = tbMFVol.value
fPrcm = tbMFPrice.value
'calc
fValm = fPrcm * fVolm
aValm = fValm - bValm - pValm
aVolm = fVolm - (bVolm + pVolm)
If nomonth Then
aPrcm = fValm / fVolm - bPrcm
Else
aPrcm = fValm / fVolm - ((bValm + pValm) / (bVolm + pVolm))
End If
Else
fValm = 0
aValm = fValm - bValm - pValm
End If
'build json
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
j("scenario")("version") = "b20"
j("scenario")("iter") = handler.basis
j("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
j("user") = Application.UserName
j("source") = "adj"
If opEditSalesM Then
If opmvol Then
If nomonth Then
j("type") = "addmonth_v"
j("month") = month(mline, 0)
Else
j("type") = "scale_v"
j("scenario")("order_month") = month(mline, 0)
End If
j("amount") = aValm
Else
If nomonth Then
'this scenario should be prevented
j("type") = "addmonth_v"
j("month") = month(mline, 0)
Else
j("type") = "scale_p"
j("scenario")("order_month") = month(mline, 0)
End If
j("amount") = aValm
End If
Else
If nomonth Then
j("type") = "addmonth_vp"
j("month") = month(mline, 0)
Else
If aVolm = 0 Then
j("type") = "scale_p"
Else
j("type") = "scale_vp"
End If
j("scenario")("order_month") = month(mline, 0)
End If
j("qty") = aVolm
j("amount") = aValm
End If
month(mline, 10) = JsonConverter.ConvertToJson(j)
tbAPI = JsonConverter.ConvertToJson(j)
If clear_lb Then MsgBox ("clear")
Me.load_mbox
Me.load_array
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
Sub new_part()
End Sub

BIN
fpvt.frx
View File

Binary file not shown.

519
handler.bas
View File

@ -1,519 +0,0 @@
Attribute VB_Name = "handler"
Option Explicit
Public sql As String
Public jsql As String
Public scenario As String
Public sc() As Variant
Public x As New TheBigOne
Public wapi As New Windows_API
Public data() As String
Public agg() As String
Public showprice As Boolean
Public server As String
Public basis() As Variant
Public baseline() As Variant
Public adjust() As Variant
Sub load_fpvt()
Application.StatusBar = "retrieving selection data....."
'data = x.SHTp_Get("data", 1, 1, True)
'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30))
Dim i As Long
Dim s_tot As Object
fpvt.ListBox1.list = handler.sc
showprice = False
For i = 0 To UBound(handler.sc, 1)
If handler.sc(i, 0) = "part_descr" Then
showprice = True
Exit For
End If
Next i
fpvt.Show
End Sub
Function scenario_package(doc As String, ByRef status As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
On Error GoTo errh
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/scenario_package", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
Set scenario_package = json
errh:
If Err.Number <> 0 Then
status = False
MsgBox (Err.Description)
Set scenario_package = Nothing
Else
status = True
End If
End Function
Sub pg_main_workset(rep As String)
Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API
Dim wr As String
Dim json As Object
Dim i As Long
Dim j As Long
Dim doc As String
Dim res() As Variant
Dim str() As String
doc = "{""quota_rep"":""" & rep & """}"
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", handler.server & "/get_pool", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
ReDim res(json("x").Count, 32)
For i = 1 To UBound(res, 1)
res(i, 0) = json("x")(i)("bill_cust_descr")
res(i, 1) = json("x")(i)("billto_group")
res(i, 2) = json("x")(i)("ship_cust_descr")
res(i, 3) = json("x")(i)("shipto_group")
res(i, 4) = json("x")(i)("quota_rep_descr")
res(i, 5) = json("x")(i)("director_descr")
res(i, 6) = json("x")(i)("segm")
res(i, 7) = json("x")(i)("mod_chan")
res(i, 8) = json("x")(i)("mod_chansub")
res(i, 9) = json("x")(i)("majg_descr")
res(i, 10) = json("x")(i)("ming_descr")
res(i, 11) = json("x")(i)("majs_descr")
res(i, 12) = json("x")(i)("mins_descr")
res(i, 13) = json("x")(i)("brand")
res(i, 14) = json("x")(i)("part_family")
res(i, 15) = json("x")(i)("part_group")
res(i, 16) = json("x")(i)("branding")
res(i, 17) = json("x")(i)("color")
res(i, 18) = json("x")(i)("part_descr")
res(i, 19) = json("x")(i)("order_season")
res(i, 20) = json("x")(i)("order_month")
res(i, 21) = json("x")(i)("ship_season")
res(i, 22) = json("x")(i)("ship_month")
res(i, 23) = json("x")(i)("request_season")
res(i, 24) = json("x")(i)("request_month")
res(i, 25) = json("x")(i)("promo")
res(i, 26) = json("x")(i)("version")
res(i, 27) = json("x")(i)("iter")
res(i, 28) = json("x")(i)("value_loc")
res(i, 29) = json("x")(i)("value_usd")
res(i, 30) = json("x")(i)("cost_loc")
res(i, 31) = json("x")(i)("cost_usd")
res(i, 32) = json("x")(i)("units")
Next i
res(0, 0) = "bill_cust_descr"
res(0, 1) = "billto_group"
res(0, 2) = "ship_cust_descr"
res(0, 3) = "shipto_group"
res(0, 4) = "quota_rep_descr"
res(0, 5) = "director_descr"
res(0, 6) = "segm"
res(0, 7) = "mod_chan"
res(0, 8) = "mod_chansub"
res(0, 9) = "majg_descr"
res(0, 10) = "ming_descr"
res(0, 11) = "majs_descr"
res(0, 12) = "mins_descr"
res(0, 13) = "brand"
res(0, 14) = "part_family"
res(0, 15) = "part_group"
res(0, 16) = "branding"
res(0, 17) = "color"
res(0, 18) = "part_descr"
res(0, 19) = "order_season"
res(0, 20) = "order_month"
res(0, 21) = "ship_season"
res(0, 22) = "ship_month"
res(0, 23) = "request_season"
res(0, 24) = "request_month"
res(0, 25) = "promo"
res(0, 26) = "version"
res(0, 27) = "iter"
res(0, 28) = "value_loc"
res(0, 29) = "value_usd"
res(0, 30) = "cost_loc"
res(0, 31) = "cost_usd"
res(0, 32) = "units"
Set json = Nothing
ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents
Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
End Sub
Sub pull_rep()
openf.Show
End Sub
Function request_adjust(doc As String, ByRef fail As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Long
Dim j As Long
Dim str() As String
If doc = "" Then
fail = True
Exit Function
End If
'update timestamp
Set json = JsonConverter.ParseJson(doc)
'json("stamp") = Format(Now, "yyyy-mm-dd hh:mm:ss")
'doc = JsonConverter.ConvertToJson(doc)
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "POST", server & "/" & json("type"), True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
If Mid(wr, 2, 5) = "error" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<body>" Then
MsgBox (wr)
fail = True
Exit Function
End If
If Mid(wr, 1, 6) = "<!DOCT" Then
MsgBox (wr)
fail = True
Exit Function
End If
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no adjustment was made")
fail = True
Exit Function
End If
ReDim res(json("x").Count - 1, 32)
For i = 1 To UBound(res, 1) + 1
res(i - 1, 0) = json("x")(i)("bill_cust_descr")
res(i - 1, 1) = json("x")(i)("billto_group")
res(i - 1, 2) = json("x")(i)("ship_cust_descr")
res(i - 1, 3) = json("x")(i)("shipto_group")
res(i - 1, 4) = json("x")(i)("quota_rep_descr")
res(i - 1, 5) = json("x")(i)("director_descr")
res(i - 1, 6) = json("x")(i)("segm")
res(i - 1, 7) = json("x")(i)("mod_chan")
res(i - 1, 8) = json("x")(i)("mod_chansub")
res(i - 1, 9) = json("x")(i)("majg_descr")
res(i - 1, 10) = json("x")(i)("ming_descr")
res(i - 1, 11) = json("x")(i)("majs_descr")
res(i - 1, 12) = json("x")(i)("mins_descr")
res(i - 1, 13) = json("x")(i)("brand")
res(i - 1, 14) = json("x")(i)("part_family")
res(i - 1, 15) = json("x")(i)("part_group")
res(i - 1, 16) = json("x")(i)("branding")
res(i - 1, 17) = json("x")(i)("color")
res(i - 1, 18) = json("x")(i)("part_descr")
res(i - 1, 19) = json("x")(i)("order_season")
res(i - 1, 20) = json("x")(i)("order_month")
res(i - 1, 21) = json("x")(i)("ship_season")
res(i - 1, 22) = json("x")(i)("ship_month")
res(i - 1, 23) = json("x")(i)("request_season")
res(i - 1, 24) = json("x")(i)("request_month")
res(i - 1, 25) = json("x")(i)("promo")
res(i - 1, 26) = json("x")(i)("version")
res(i - 1, 27) = json("x")(i)("iter")
res(i - 1, 28) = json("x")(i)("value_loc")
res(i - 1, 29) = json("x")(i)("value_usd")
res(i - 1, 30) = json("x")(i)("cost_loc")
res(i - 1, 31) = json("x")(i)("cost_usd")
res(i - 1, 32) = json("x")(i)("units")
Next i
Set json = Nothing
ReDim str(UBound(res, 1), UBound(res, 2))
' For i = 0 To UBound(res, 1)
' For j = 0 To UBound(res, 2)
' If IsNull(res(i, j)) Then
' str(i, j) = ""
' Else
' str(i, j) = res(i, j)
' End If
' Next j
' Next i
i = 1
Do Until Sheets("data").Cells(i, 1) = ""
i = i + 1
Loop
Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
End Function
Sub load_config()
Dim i As Integer
Dim j As Integer
'----server to use---------------------------------------------------------
handler.server = Sheets("config").Cells(1, 2)
'---basis-----------------------------------------------------------------
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
'---baseline-----------------------------------------------------------------
ReDim handler.baseline(100)
i = 2
j = 0
Do While Sheets("config").Cells(3, i) <> ""
handler.baseline(j) = Sheets("config").Cells(3, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.baseline(j - 1)
'---adjustments-----------------------------------------------------------------
ReDim handler.adjust(100)
i = 2
j = 0
Do While Sheets("config").Cells(4, i) <> ""
handler.adjust(j) = Sheets("config").Cells(4, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.adjust(j - 1)
End Sub
Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
Dim j As Object
Dim i As Integer
Dim r As Long
Dim sh As Worksheet
Set sh = Sheets("_month")
Set j = JsonConverter.ParseJson("{""scenario"":" & scenario & "}")
sh.Cells(1, 16) = JsonConverter.ConvertToJson(j)
For i = 0 To 12
'------------volume-------------------
sh.Cells(i + 1, 1) = co_num(pkg(i, 1), 0)
sh.Cells(i + 1, 2) = co_num(pkg(i, 2), 0)
sh.Cells(i + 1, 3) = co_num(pkg(i, 3), 0)
sh.Cells(i + 1, 4) = 0
sh.Cells(i + 1, 5) = co_num(pkg(i, 4), 0)
'------------value----------------------
sh.Cells(i + 1, 11) = co_num(pkg(i, 5), 0)
sh.Cells(i + 1, 12) = co_num(pkg(i, 6), 0)
sh.Cells(i + 1, 13) = co_num(pkg(i, 7), 0)
sh.Cells(i + 1, 14) = 0
sh.Cells(i + 1, 15) = co_num(pkg(i, 8), 0)
'-------------price----------------------
If i > 0 Then
'--prior--
If co_num(pkg(i, 1), 0) = 0 Then
sh.Cells(i + 1, 6) = 0
Else
sh.Cells(i + 1, 6) = pkg(i, 5) / pkg(i, 1)
End If
'--base--
If co_num(pkg(i, 2), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If sh.Cells(i, 7) <> 0 Then
sh.Cells(i + 1, 7) = sh.Cells(i, 7)
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 7) = 0
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Or pkg(i, 2) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = (pkg(i, 7) + pkg(i, 6)) / (pkg(i, 3) + pkg(i, 2)) - (pkg(i, 6) / pkg(i, 2))
End If
'--current adjust--
sh.Cells(i + 1, 9) = 0
'--forecast--
If co_num(pkg(i, 4), 0) = 0 Then
'if there is no monthly base volume,
'then use the prior price, if there was no prior price,
'then inherit the average price for the year before current adjustments
If sh.Cells(i, 10) <> 0 Then
sh.Cells(i + 1, 10) = sh.Cells(i, 10)
Else
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 10) = 0
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
End If
Next i
'scenario
Sheets("_month").Range("R1:S1000").ClearContents
For i = 0 To UBound(handler.sc, 1)
sh.Cells(i + 1, 18) = handler.sc(i, 0)
sh.Cells(i + 1, 19) = handler.sc(i, 1)
Next i
'basket
sh.Range("U1:AC100000").ClearContents
Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
Sheets("config").Cells(5, 2) = 0
Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 2) = 0
months.load_sheet
End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
If one = "" Or IsNull(one) Then
co_num = two
Else
co_num = one
End If
End Function
Function list_changes(doc As String, ByRef fail As Boolean) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/list_changes", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no history")
fail = True
Exit Function
End If
ReDim res(json("x").Count - 1, 5)
For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("user")
res(i, 1) = json("x")(i + 1)("stamp")
res(i, 2) = json("x")(i + 1)("comment")
res(i, 3) = json("x")(i + 1)("sales")
res(i, 4) = json("x")(i + 1)("def")
Next i
list_changes = res
End Function
Sub history()
changes.Show
End Sub

35
login.frm
View File

@ -1,35 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} login
Caption = "CMS Login"
ClientHeight = 2295
ClientLeft = 120
ClientTop = 465
ClientWidth = 2445
OleObjectBlob = "login.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "login"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public proceed As Boolean
Private Sub cbCANCEL_Click()
tbU.Text = ""
tbP.Text = ""
proceed = False
Me.Hide
End Sub
Private Sub cbOK_Click()
proceed = True
Me.Hide
End Sub
Private Sub UserForm_Terminate()
proceed = False
End Sub

BIN
login.frx
View File

Binary file not shown.

963
months.cls
View File

@ -1,963 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "months"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private x As New TheBigOne
Private units() As Variant
Private price() As Variant
Private sales() As Variant
Private tunits() As Variant
Private tprice() As Variant
Private tsales() As Variant
Private dumping As Boolean
Private vedit As String
Private adjust() As Object
Private jtext() As Variant
Private basejson As Object
Private rollback As Boolean
Private scenario() As Variant
Private orig As Range
Private basket_touch As Range
Private showbasket As Boolean
Private np As Object 'json dedicated to new part scenario
Private b() As Variant 'holds basket
Private Sub Worksheet_Change(ByVal target As Range)
If Not dumping Then
If Not Intersect(target, Range("A1:R18")) Is Nothing Then
If target.Columns.Count > 1 Then
MsgBox ("you can only change one column at a time - your change will be undone")
dumping = True
Application.Undo
dumping = False
Exit Sub
End If
End If
If Not Intersect(target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj
If Not Intersect(target, Range("F6:F17")) Is Nothing Then Call Me.mvp_set
If Not Intersect(target, Range("K6:K17")) Is Nothing Then Call Me.mvp_adj
If Not Intersect(target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set
If Not Intersect(target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj
If Not Intersect(target, Range("R6:R17")) Is Nothing Then Call Me.ms_set
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
Set basket_touch = target
Call Me.get_edit_basket
Set basket_touch = Nothing
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True
Call Me.basket_pick(target)
target.Select
End If
End Sub
Sub picker_shortcut()
If Not Intersect(Selection, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
Call Me.basket_pick(Selection)
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean)
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True
Call Me.basket_pick(target)
target.Select
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
Call Me.get_sheet
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
Me.crunch_array
Me.build_json
Me.set_sheet
End Sub
Sub mvp_adj()
Dim i As Integer
Call Me.get_sheet
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
Me.crunch_array
Me.build_json
Me.set_sheet
End Sub
Sub ms_set()
On Error GoTo errh
Dim i As Integer
Call Me.get_sheet
Dim vp As String
vp = Sheets("month").Range("Q2")
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))
Select Case vp
Case "volume"
If co_num(price(i, 5), 0) = 0 Then
MsgBox ("price cannot be -0- and also have sales - your change will be undone")
dumping = True
Application.Undo
dumping = False
Exit Sub
End If
'reset price to original - delete these lines if a cascading effect is desired
'price(i, 4) = 0
'price(i, 5) = price(i, 2) + price(i, 3)
'calc volume change on original price
units(i, 5) = sales(i, 5) / price(i, 5)
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
Case "price"
If co_num(units(i, 5), 0) = 0 Then
MsgBox ("volume cannot be -0- and also have sales - your change will be undone")
dumping = True
Application.Undo
dumping = 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))
Case Else
MsgBox ("error forcing sales with no offset specified - your change will be undone")
dumping = True
Application.Undo
dumping = False
Exit Sub
End Select
End If
Next i
Me.crunch_array
Me.build_json
Me.set_sheet
errh:
If Err.Number <> 0 Then rollback = True
End Sub
Sub ms_adj()
Dim i As Integer
Call Me.get_sheet
Dim vp As String
vp = Sheets("month").Range("Q2")
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)
Select Case vp
Case "volume"
If co_num(price(i, 5), 0) = 0 Then
MsgBox ("price cannot be -0- and also have sales - your change will be undone")
dumping = True
Application.Undo
dumping = False
Exit Sub
End If
'reset price to original
'price(i, 4) = 0
'price(i, 5) = price(i, 2) + price(i, 3)
'calc volume change on original price
units(i, 5) = sales(i, 5) / price(i, 5)
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
Case "price"
If co_num(units(i, 5), 0) = 0 Then
MsgBox ("volume cannot be -0- and also have sales - your change will be undone")
dumping = True
Application.Undo
dumping = 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))
Case Else
MsgBox ("error forcing sales with no offset specified - your change will be undone")
dumping = True
Application.Undo
dumping = False
Exit Sub
End Select
End If
Next i
Me.crunch_array
Me.build_json
Me.set_sheet
End Sub
Sub get_sheet()
Dim i As Integer
units = Range("B6:F17")
price = Range("H6:L17")
sales = Range("N6:R17")
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1)
End Sub
Sub set_sheet()
Dim i As Integer
dumping = True
Range("B6:F17") = units
Range("H6:L17") = price
Range("N6:R17") = sales
Range("B18:F18").FormulaR1C1 = tunits
Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales
Range("T6:U18").ClearContents
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False)
'Sheets("month").Range("B32:Q5000").ClearContents
If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
dumping = False
End Sub
Sub load_sheet()
units = Sheets("_month").Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1
scenario = Sheets("_month").Range("R1:S13").FormulaR1C1
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
'reset basket
Sheets("_month").Range("U1:X10000").ClearContents
Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False)
ReDim adjust(12)
Call Me.crunch_array
Call Me.set_sheet
Call Me.print_basket
Call Me.set_format
End Sub
Sub set_format()
Dim prices As Range
Dim price_adj As Range
Dim price_set As Range
Dim vol As Range
Dim vol_adj As Range
Dim vol_set As Range
Dim val As Range
Dim val_adj As Range
Dim val_set As Range
Set prices = Sheets("month").Range("H6:L17")
Set price_adj = Sheets("month").Range("K6:K17")
Set price_set = Sheets("month").Range("L6:L17")
Set vol = Sheets("month").Range("B6:F17")
Set vol_adj = Sheets("month").Range("E6:E17")
Set vol_set = Sheets("month").Range("F6:F17")
Set val = Sheets("month").Range("N6:R17")
Set val_adj = Sheets("month").Range("Q6:Q17")
Set val_set = Sheets("month").Range("R6:R17")
Call Me.format_price(prices)
Call Me.set_border(prices)
Call Me.fill_yellow(price_adj)
Call Me.fill_none(price_set)
Call Me.format_number(vol)
Call Me.set_border(vol)
Call Me.fill_yellow(vol_adj)
Call Me.fill_none(vol_set)
Call Me.format_number(val)
Call Me.set_border(val)
Call Me.fill_yellow(val_adj)
Call Me.fill_none(val_set)
End Sub
Sub set_border(ByRef targ As Range)
targ.Borders(xlDiagonalDown).LineStyle = xlNone
targ.Borders(xlDiagonalUp).LineStyle = xlNone
With targ.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With targ.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With targ.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With targ.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With targ.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With targ.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Sub fill_yellow(ByRef target As Range)
With target.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Sub
Sub fill_grey(ByRef target As Range)
With target.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End Sub
Sub fill_none(ByRef target As Range)
With target.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Sub format_price(ByRef target As Range)
target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
End Sub
Sub format_number(ByRef target As Range)
target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
End Sub
Sub build_json()
Dim i As Long
Dim j As Long
Dim pos As Long
Dim o As Object
Dim m As Object
Dim list As Object
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
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") = "b20"
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj"
np("type") = "new_basket"
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(Worksheets("month").Cells(5 + 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
If Round(price(pos, 5), 8) <> Round(tprice(1, 2) + tprice(1, 3), 8) Then
'if the target price is diferent from the average and a month is being added
adjust(pos)("type") = "addmonth_vp"
Else
'if the target price is the same as average and a month is being added
adjust(pos)("type") = "addmonth_v"
End If
adjust(pos)("month") = Worksheets("month").Cells(5 + 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") = Worksheets("month").Cells(5 + 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") = "b20"
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") = Worksheets("month").Range("B33").value
'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet
b = Worksheets("_month").Range("U1").CurrentRegion.value
Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False))
If UBound(b, 1) <= 2 Then
Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]")
Else
Set np("basket") = m("basket")
End If
End If
If Me.newpart Then
Sheets("_month").Range("P2:P13").ClearContents
Sheets("_month").Cells(2, 16) = JsonConverter.ConvertToJson(np)
Else
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
End If
End Sub
Sub crunch_array()
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()
Sheets("Orders").Select
End Sub
Sub reset()
Call Me.load_sheet
End Sub
Sub switch_basket()
If Sheets("config").Cells(6, 2) = 1 Then
Sheets("config").Cells(6, 2) = 0
Else
Sheets("config").Cells(6, 2) = 1
End If
Call Me.print_basket
End Sub
Sub print_basket()
'Sheets("config").Cells(6, 2) = 1
If Sheets("config").Cells(6, 2) = 0 Then
dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents
Rows("20:31").Hidden = False
dumping = False
Exit Sub
End If
Dim i As Long
Dim basket() As Variant
basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
dumping = True
Worksheets("month").Range("B32:Q10000").ClearContents
For i = 1 To UBound(basket, 1)
Sheets("month").Cells(31 + i, 2) = basket(i, 1)
Sheets("month").Cells(31 + i, 6) = basket(i, 2)
Sheets("month").Cells(31 + i, 12) = basket(i, 3)
Sheets("month").Cells(31 + i, 17) = basket(i, 4)
Next i
Rows("20:31").Hidden = True
dumping = False
End Sub
Sub basket_pick(ByRef target As Range)
Dim i As Long
build.part = Sheets("month").Cells(target.row, 2)
build.bill = rev_cust(Sheets("month").Cells(target.row, 6))
build.ship = rev_cust(Sheets("month").Cells(target.row, 12))
build.useval = False
build.Show
If build.useval Then
dumping = True
'if an empty row is selected, force it to be the next open slot
If Sheets("month").Cells(target.row, 2) = "" Then
Do Until Sheets("month").Cells(target.row + i, 2) <> ""
i = i - 1
Loop
i = i + 1
End If
Sheets("month").Cells(target.row + i, 2) = build.cbPart.value
Sheets("month").Cells(target.row + i, 6) = rev_cust(build.cbBill.value)
Sheets("month").Cells(target.row + i, 12) = rev_cust(build.cbShip.value)
dumping = False
Set basket_touch = Selection
Call Me.get_edit_basket
Set basket_touch = Nothing
End If
target.Select
End Sub
Sub get_edit_basket()
Dim i As Long
Dim mix As Double
Dim touch_mix As Double
Dim untouched As Long
Dim touch() As Boolean
'ReDim b(basket_rows, 3)
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
i = i + 1
Loop
i = i - 1
ReDim b(i, 3)
ReDim touch(i)
untouched = i + 1
i = 0
mix = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
b(i, 0) = Worksheets("month").Cells(33 + i, 2)
b(i, 1) = Worksheets("month").Cells(33 + i, 6)
b(i, 2) = Worksheets("month").Cells(33 + i, 12)
b(i, 3) = Worksheets("month").Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0
mix = mix + b(i, 3)
If Not Intersect(basket_touch, Worksheets("month").Cells(33 + i, 17)) Is Nothing Then
touch_mix = touch_mix + b(i, 3)
touch(i) = True
untouched = untouched - 1
End If
i = i + 1
Loop
'evaluate mix changes and force to 100
For i = 0 To UBound(b, 1)
If Not touch(i) Then
If mix - touch_mix = 0 Then
b(i, 3) = (1 - mix) / untouched
Else
b(i, 3) = b(i, 3) + b(i, 3) * (1 - mix) / (mix - touch_mix)
End If
End If
Next i
dumping = True
'put the mix plug back on the the sheet
For i = 0 To UBound(b, 1)
Worksheets("month").Cells(33 + i, 17) = b(i, 3)
Next i
dumping = False
Worksheets("_month").Range("U2:X5000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
If Me.newpart Then
Me.build_json
End If
End Sub
Sub post_adjust()
Dim i As Long
Dim fail As Boolean
If Me.newpart Then
Call handler.request_adjust(Sheets("_month").Cells(2, 16), fail)
If fail Then Exit Sub
Else
For i = 2 To 13
If Sheets("_month").Cells(i, 16) <> "" Then
Call handler.request_adjust(Sheets("_month").Cells(i, 16), fail)
If fail Then Exit Sub
End If
Next i
End If
Sheets("Orders").Select
'Worksheets("month").Visible = xlHidden
End Sub
Sub build_new()
Worksheets("config").Cells(5, 2) = 1
Dim i As Long
Dim j As Long
Dim basket() As Variant
Dim m() As Variant
dumping = True
m = Sheets("_month").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
Worksheets("_month").Range("A2:O13") = m
Worksheets("_month").Range("U2:X1000").ClearContents
Worksheets("_month").Range("Z2:AC1000").ClearContents
Worksheets("_month").Range("R2:S1000").ClearContents
Call Me.load_sheet
'Call Me.set_sheet
'Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False)
basket = x.SHTp_get_block(Worksheets("_month").Range("U1"))
Sheets("month").Cells(32, 2) = basket(1, 1)
Sheets("month").Cells(32, 6) = basket(1, 2)
Sheets("month").Cells(32, 12) = basket(1, 3)
Sheets("month").Cells(32, 17) = basket(1, 4)
Call Me.print_basket
dumping = 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 = x.SHTp_Get("_month", 1, 27, True)
If Not x.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then
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
dumping = True
Worksheets("month").Range("B33:Q10000").ClearContents
For i = 1 To UBound(cust, 2)
Sheets("month").Cells(32 + i, 2) = part.cbPart.value
Sheets("month").Cells(32 + i, 6) = cust(0, i)
Sheets("month").Cells(32 + i, 12) = cust(1, i)
Sheets("month").Cells(32 + i, 17) = CDbl(cust(2, i))
Next i
Sheets("config").Cells(7, 2) = 1
'------copy revised basket to _month storage---------------------------------------------------
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
i = i + 1
Loop
i = i - 1
If i = -1 Then i = 0
ReDim b(i, 3)
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""
b(i, 0) = Worksheets("month").Cells(33 + i, 2)
b(i, 1) = Worksheets("month").Cells(33 + i, 6)
b(i, 2) = Worksheets("month").Cells(33 + i, 12)
b(i, 3) = Worksheets("month").Cells(33 + i, 17)
If b(i, 3) = "" Then b(i, 3) = 0
i = i + 1
Loop
Worksheets("_month").Range("U2:AC10000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
Call x.SHTp_DumpVar(b, "_month", 2, 26, False, False, True)
'------reset volume to copy base to forecsat and clear base------------------------------------
units = Sheets("_month").Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1
tunits = Range("B18:F18")
tprice = Range("H18:L18")
tsales = Range("N18:R18")
ReDim adjust(12)
Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1)
For i = 1 To 12
'volume
units(i, 5) = units(i, 2)
units(i, 4) = units(i, 2)
units(i, 1) = 0
units(i, 2) = 0
units(i, 3) = 0
'sales
sales(i, 5) = sales(i, 2)
sales(i, 4) = sales(i, 2)
sales(i, 1) = 0
sales(i, 2) = 0
sales(i, 3) = 0
'price
price(i, 5) = price(i, 2)
price(i, 4) = price(i, 2)
price(i, 1) = 0
price(i, 2) = 0
price(i, 3) = 0
Next i
Call Me.crunch_array
Call Me.build_json
Call Me.set_sheet
'-------------push revised arrays back to _month, not revertable-------------------------------
Worksheets("_month").Range("A2:E13") = units
Worksheets("_month").Range("F2:J13") = price
Worksheets("_month").Range("K2:o13") = sales
'force basket to show to demonstrate the part was changed
Sheets("config").Cells(6, 2) = 1
Call Me.print_basket
dumping = False
End Sub
Function newpart() As Boolean
If Worksheets("config").Cells(7, 2) = 1 Then
newpart = True
Else
newpart = False
End If
End Function

51
openf.frm
View File

@ -1,51 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} openf
Caption = "Open a Forecast"
ClientHeight = 2025
ClientLeft = 120
ClientTop = 465
ClientWidth = 3825
OleObjectBlob = "openf.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "openf"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cbCancel_Click()
openf.Hide
End Sub
Private Sub cbOK_Click()
Application.StatusBar = "Retrieving data for " & cbDSM.value & "....."
openf.Caption = "retrieving data......"
Call handler.pg_main_workset(cbDSM.value)
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
Application.StatusBar = False
openf.Hide
End Sub
Private Sub UserForm_Activate()
'handler.server = "http://192.168.1.69:3000"
handler.server = Sheets("config").Cells(1, 2)
Dim x As New TheBigOne
Dim d() As String
openf.Caption = "Select a DSM"
d = x.SHTp_Get("reps", 1, 1, True)
For i = 1 To UBound(d, 2)
Call cbDSM.AddItem(d(0, i))
Next i
End Sub

BIN
openf.frx
View File

Binary file not shown.

48
part.frm
View File

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

BIN
part.frx
View File

Binary file not shown.

107
pivot.bas
View File

@ -1,107 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
Cancel = True
Dim i As Long
Dim j As Long
Dim k As Long
Dim ri As PivotItemList
Dim ci As PivotItemList
Dim df As Object
Dim rd As Object
Dim cd As Object
Dim dd As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim wapi As New Windows_API
Set ri = Target.Cells.PivotCell.RowItems
Set ci = Target.Cells.PivotCell.ColumnItems
Set df = Target.Cells.PivotCell.DataField
Set rd = Target.Cells.PivotTable.RowFields
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
For i = 1 To ri.Count
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & ri(i).Name & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & ri(i).Name & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name
Next i
scenario = "{" & handler.jsql & "}"
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub
Function piv_pos(list As Object, target_pos As Long) As Long
Dim i As Long
For i = 1 To list.Count
If list(i).Position = target_pos Then
piv_pos = i
Exit Function
End If
Next i
'should not get to this point
End Function
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
Dim i As Integer
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i).Name = field_name Then
piv_fld_index = i
Exit Function
End If
Next i
End Function

113
pivot.cls
View File

@ -1,113 +0,0 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
If Intersect(target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
cancel = True
Dim i As Long
Dim j As Long
Dim k As Long
Dim ri As PivotItemList
Dim ci As PivotItemList
Dim df As Object
Dim rd As Object
Dim cd As Object
Dim dd As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim wapi As New Windows_API
Set ri = target.Cells.PivotCell.RowItems
Set ci = target.Cells.PivotCell.ColumnItems
Set df = target.Cells.PivotCell.DataField
Set rd = target.Cells.PivotTable.RowFields
Set cd = target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
For i = 1 To ri.Count
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape(ri(i).Name) & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape(ri(i).Name) & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name
Next i
scenario = "{" & handler.jsql & "}"
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub
Function piv_pos(list As Object, target_pos As Long) As Long
Dim i As Long
For i = 1 To list.Count
If list(i).Position = target_pos Then
piv_pos = i
Exit Function
End If
Next i
'should not get to this point
End Function
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
Dim i As Integer
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i).Name = field_name Then
piv_fld_index = i
Exit Function
End If
Next i
End Function
Function escape(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", """""")
If text = "(blank)" Then text = ""
escape = text
End Function

48
pricelist.frm
View File

@ -1,48 +0,0 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist
Caption = "Price List Name"
ClientHeight = 5115
ClientLeft = 120
ClientTop = 465
ClientWidth = 4110
OleObjectBlob = "pricelist.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "pricelist"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public proceed As Boolean
Private Sub bCANCEL_Click()
proceed = False
Me.Hide
End Sub
Private Sub bOK_Click()
proceed = True
Me.Hide
End Sub
Private Sub bPICK_Click()
'--------Open file-------------
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
tbPATH.Text = fd.SelectedItems(1)
End Sub
Private Sub UserForm_Initialize()
proceed = False
End Sub
Private Sub UserForm_Terminate()
proceed = False
End Sub

BIN
pricelist.frx
View File

Binary file not shown.