add functionality to display basket

This commit is contained in:
Trowbridge 2019-03-19 01:03:43 -04:00
parent e7071a777c
commit 9b8a486981
5 changed files with 270 additions and 41 deletions

View File

@ -16,7 +16,7 @@ Public ADOo_errstring As String
Public Enum ADOinterface
MicrosoftJetOLEDB4 = 0
MicrosoftACEOLEDB12 = 1
SQLServer = 2
SqlServer = 2
SQLServerNativeClient = 3
SQLServerNativeClient10 = 4
OracleODBC = 5
@ -28,7 +28,7 @@ End Enum
Public Enum SQLsyntax
Db2 = 0
SQLServer = 1
SqlServer = 1
PostgreSQL = 2
End Enum
@ -396,7 +396,33 @@ 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
If UBound(NumFields()) <> -1 Then
Dim i As Integer
i = 0
For i = 0 To UBound(NumFields())
Call sh.Columns(NumFields(i) + 1).TextToColumns
Next i
End If
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, ParamArray NumFields())
Dim sh As Worksheet
Set sh = Sheets(sheet)
'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
On Error GoTo errhndl
@ -416,19 +442,19 @@ End Sub
Sub ARRAYp_Transpose(ByRef a() As String)
Dim s() As String
ReDim s(UBound(a, 2), UBound(a, 1))
Dim S() As String
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)
For i = 0 To UBound(S, 1)
For j = 0 To UBound(S, 2)
S(i, j) = a(j, i)
Next j
Next i
a = s
a = S
End Sub
@ -473,6 +499,7 @@ errhdnl:
End Function
Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVal Filter As String, ByVal Equals As Boolean)
@ -529,8 +556,8 @@ Function SQLp_RollingMonthList(ByRef mmmyy As String, ByRef outformat As String,
Dim i As Integer
cmn = Format(DateValue(Left(mmmyy, 3) & "-01-" & Right(mmmyy, 2)), "m")
cy = Right(mmmyy, 2)
cmn = Format(DateValue(left(mmmyy, 3) & "-01-" & right(mmmyy, 2)), "m")
cy = right(mmmyy, 2)
For i = 0 To monthcount - 1
If i <> 0 Then mlist = mlist & ","
@ -554,21 +581,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)
@ -1301,7 +1328,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
@ -1371,7 +1398,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
@ -1403,13 +1430,13 @@ End Function
Public Function ROWp_CreateKey(ByRef tbl() As String, ByRef flds() As Integer, ByRef row As Long) As String
Dim i As Integer
Dim s As String
Dim S As String
For i = 0 To UBound(flds)
s = s & tbl(flds(i), row)
S = S & tbl(flds(i), row)
Next i
ROWp_CreateKey = s
ROWp_CreateKey = S
End Function
@ -1438,7 +1465,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
@ -1594,7 +1621,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
@ -1957,7 +1984,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
@ -1986,7 +2013,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
@ -2009,7 +2036,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
@ -2017,7 +2044,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
@ -2142,7 +2169,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) As String
Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_format As String) As String
@ -2163,6 +2190,7 @@ Public Function markdown_from_table(ByRef tbl() As Variant) As String
'---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, "-") & "|"
@ -2180,9 +2208,10 @@ Public Function markdown_from_table(ByRef tbl() As Variant) As String
End Function
Public Function json_multirange(ByRef r As range) As String
Dim ar As range
Public Function json_multirange(ByRef r As Range) As String
Dim ar As Range
Dim r1() As Variant
Dim r2() As Variant
Dim rslt As String
@ -2216,7 +2245,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)
@ -2227,13 +2256,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_colnum_to_letter(ByRef x As Long) As String
Function MISCe_col_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)
@ -2243,6 +2272,7 @@ Function MISCe_colnum_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) As String
@ -2333,7 +2363,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"
@ -2345,7 +2375,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
@ -2374,3 +2404,87 @@ 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
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.Misc_ConvBase10(left - 1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
rcol = Me.Misc_ConvBase10(right - 1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Set r = Worksheets("_month").Range(lcol & top & ":" & rcol & bot)
SHTp_get_block = r
End Function

View File

@ -23,6 +23,7 @@ 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
@ -366,7 +367,41 @@ Private Sub UserForm_Activate()
month(0, 8) = "2020 val"
Me.crunch_array
Call handler.month_tosheet(month)
ReDim basket(sp("package")("basket").Count, 4)
' 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
End Sub

BIN
fpvt.frx

Binary file not shown.

View File

@ -52,6 +52,7 @@ Function scenario_package(doc As String, ByRef status As Boolean) As Object
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
@ -334,10 +335,11 @@ Sub load_config()
End Sub
Sub month_tosheet(ByRef pkg() As Variant)
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")
@ -406,12 +408,24 @@ Sub month_tosheet(ByRef pkg() As Variant)
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If
'--json--
End If
Next i
'scenario
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:Y100000").ClearContents
For i = 0 To UBound(basket, 2)
For r = 0 To UBound(basket, 1)
sh.Cells(r + 1, i + 21) = basket(r, i)
Next r
Next i
months.load_sheet
End Sub
@ -425,3 +439,5 @@ Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
End If
End Function

View File

@ -22,6 +22,8 @@ Private adjust() As Object
Private jtext() As Variant
Private basejson As Object
Private rollback As Boolean
Private scenario() As Variant
Private orig As Range
@ -38,6 +40,8 @@ Private Sub Worksheet_Change(ByVal target As Range)
Exit Sub
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
@ -63,7 +67,11 @@ Sub mvp_set()
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
Call Me.build_json(i)
Next i
@ -84,7 +92,11 @@ Sub mvp_adj()
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
Call Me.build_json(i)
Next i
@ -102,6 +114,7 @@ Sub ms_set()
vp = Sheets("month").Range("R2")
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)), 6) <> Round(sales(i, 4), 6) Then
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
Select Case vp
@ -154,6 +167,7 @@ Sub ms_adj()
vp = Sheets("month").Range("R2")
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
@ -226,19 +240,29 @@ Sub set_sheet()
Range("B18:F18").FormulaR1C1 = tunits
Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales
Range("T6:U18").FormulaR1C1 = scenario
Sheets("month").Range("B32:Q5000").ClearContents
For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i
ActiveWindow.FreezePanes = False
Rows("19:32").Hidden = False
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")
@ -246,6 +270,8 @@ Sub load_sheet()
Me.crunch_array
Me.set_sheet
End Sub
Sub set_format()
@ -369,7 +395,7 @@ End Sub
Sub build_json(ByVal pos As Integer)
'if something is changing
If Round(units(pos, 4), 2) <> 0 Or Round(price(pos, 4), 8) <> 0 Or Round(sales(pos, 4), 8) <> 0 Then
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
@ -445,4 +471,42 @@ Sub reset()
Call Me.load_sheet
End Sub
Sub show_basket()
Dim i As Long
Dim basket() As Variant
basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
dumping = True
Application.ScreenUpdating = False
Set orig = Selection
ActiveWindow.FreezePanes = False
For i = 1 To UBound(basket, 1) - 1
Sheets("month").Cells(32 + i, 2) = basket(i + 1, 1)
Sheets("month").Cells(32 + i, 6) = basket(i + 1, 2)
Sheets("month").Cells(32 + i, 12) = basket(i + 1, 3)
Sheets("month").Cells(32 + i, 17) = basket(i + 1, 4)
Next i
Rows("20:20").Select
ActiveWindow.FreezePanes = True
Rows("20:31").Select
Selection.EntireRow.Hidden = True
orig.Select
Application.ScreenUpdating = True
dumping = False
End Sub