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 Public Enum ADOinterface
MicrosoftJetOLEDB4 = 0 MicrosoftJetOLEDB4 = 0
MicrosoftACEOLEDB12 = 1 MicrosoftACEOLEDB12 = 1
SQLServer = 2 SqlServer = 2
SQLServerNativeClient = 3 SQLServerNativeClient = 3
SQLServerNativeClient10 = 4 SQLServerNativeClient10 = 4
OracleODBC = 5 OracleODBC = 5
@ -28,7 +28,7 @@ End Enum
Public Enum SQLsyntax Public Enum SQLsyntax
Db2 = 0 Db2 = 0
SQLServer = 1 SqlServer = 1
PostgreSQL = 2 PostgreSQL = 2
End Enum 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 clear Then sh.Cells.clear
If transpose Then Call Me.ARRAYp_Transpose(tbl) 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 On Error GoTo errhndl
@ -416,19 +442,19 @@ End Sub
Sub ARRAYp_Transpose(ByRef a() As String) Sub ARRAYp_Transpose(ByRef a() As String)
Dim s() As String Dim S() As String
ReDim s(UBound(a, 2), UBound(a, 1)) ReDim S(UBound(a, 2), UBound(a, 1))
Dim i As Long Dim i As Long
Dim j As Long Dim j As Long
For i = 0 To UBound(s, 1) For i = 0 To UBound(S, 1)
For j = 0 To UBound(s, 2) For j = 0 To UBound(S, 2)
s(i, j) = a(j, i) S(i, j) = a(j, i)
Next j Next j
Next i Next i
a = s a = S
End Sub End Sub
@ -473,6 +499,7 @@ errhdnl:
End Function End Function
Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVal Filter As String, ByVal Equals As Boolean) 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 Dim i As Integer
cmn = Format(DateValue(Left(mmmyy, 3) & "-01-" & Right(mmmyy, 2)), "m") cmn = Format(DateValue(left(mmmyy, 3) & "-01-" & right(mmmyy, 2)), "m")
cy = Right(mmmyy, 2) cy = right(mmmyy, 2)
For i = 0 To monthcount - 1 For i = 0 To monthcount - 1
If i <> 0 Then mlist = mlist & "," 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 j As Long
Dim m As Long Dim m As Long
Dim k As Long Dim k As Long
Dim OK As Boolean Dim ok As Boolean
m = -1 m = -1
i = 0 i = 0
While i <= UBound(tbl, 1) While i <= UBound(tbl, 1)
k = 0 k = 0
OK = True ok = True
Do While k <= UBound(column()) Do While k <= UBound(column())
If i = column(k) Then If i = column(k) Then
OK = False ok = False
Exit Do Exit Do
End If End If
k = k + 1 k = k + 1
Loop Loop
If OK = True Then If ok = True Then
m = m + 1 m = m + 1
j = 0 j = 0
While j <= UBound(tbl, 2) While j <= UBound(tbl, 2)
@ -1301,7 +1328,7 @@ Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As
End Function 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 On Error GoTo errpath
'has to be a lexicographically sorted table otherwise this evaluaiton will not be the same as the sort evaluaiton '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 j = currow
End If End If
range = i Range = i
ROWe_FindOnSorted = j ROWe_FindOnSorted = j
match = True match = True
Exit Function 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 Public Function ROWp_CreateKey(ByRef tbl() As String, ByRef flds() As Integer, ByRef row As Long) As String
Dim i As Integer Dim i As Integer
Dim s As String Dim S As String
For i = 0 To UBound(flds) For i = 0 To UBound(flds)
s = s & tbl(flds(i), row) S = S & tbl(flds(i), row)
Next i Next i
ROWp_CreateKey = s ROWp_CreateKey = S
End Function End Function
@ -1438,7 +1465,7 @@ Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITL
MsgB.Caption = TITLE MsgB.Caption = TITLE
MsgB.tbMSG.ScrollBars = fmScrollBarsBoth MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
MsgB.Show MsgB.Show
MISC_msgbox_cancel = MsgB.Cancel MISC_msgbox_cancel = MsgB.cancel
Application.EnableCancelKey = xlInterrupt Application.EnableCancelKey = xlInterrupt
End Function End Function
@ -1594,7 +1621,7 @@ Sub SHTp_HyperlinkConvert(ByRef sheet As Worksheet, ByRef column As Integer, ByR
Set sh = sheet Set sh = sheet
i = startrow i = startrow
Do Until sh.Cells(i, column) = stopflag 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 i = i + 1
Loop Loop
@ -1957,7 +1984,7 @@ Function TXTp_ParseCSVrow(ByRef csv() As String, row As Long, col As Integer) As
End Function 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 json As String
Dim i As Integer Dim i As Integer
@ -1986,7 +2013,7 @@ Function json_from_list(keys As range, values As range) As String
End Function End Function
Function json_concat(list As range) As String Function json_concat(list As Range) As String
Dim json As String Dim json As String
Dim i As Integer Dim i As Integer
@ -2009,7 +2036,7 @@ Function json_concat(list As range) As String
End Function 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 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 sql As String
Dim rec As String Dim rec As String
sql = "INSERT INTO " & Target & " VALUES " & vbCrLf sql = "INSERT INTO " & target & " VALUES " & vbCrLf
For i = start To ending For i = start To ending
rec = "" rec = ""
If i <> start Then sql = sql & "," & vbCrLf 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 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----------- '---build markdown table-----------
For r = 1 To UBound(tbl, 1) For r = 1 To UBound(tbl, 1)
If r = 2 Then If r = 2 Then
'If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
md = md & "|" md = md & "|"
For c = 1 To UBound(tbl, 2) For c = 1 To UBound(tbl, 2)
md = md & "---" & String(Me.MISCe_MaxInt(msl(c), 3) - 3, "-") & "|" 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 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 r1() As Variant
Dim r2() As Variant Dim r2() As Variant
Dim rslt As String Dim rslt As String
@ -2216,7 +2245,7 @@ Function markdown_whole_sheet(ByRef sh As Worksheet) As String
Dim x As New TheBigOne Dim x As New TheBigOne
Dim tbl() As Variant Dim tbl() As Variant
tbl = sh.range("A1:CZ1000").FormulaR1C1 tbl = sh.Range("A1:CZ1000").FormulaR1C1
For ic = 1 To UBound(tbl, 2) For ic = 1 To UBound(tbl, 2)
For ir = 1 To UBound(tbl, 1) For ir = 1 To UBound(tbl, 1)
@ -2227,13 +2256,13 @@ Function markdown_whole_sheet(ByRef sh As Worksheet) As String
Next ir Next ir
Next ic 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) markdown_whole_sheet = Me.markdown_from_table(tbl)
End Function 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 If x > 26 Then
MISCe_colnum_to_letter = Chr(x \ 26 + 64) & Chr((x / 26 - x \ 26) * 26 + 64) 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 End Function
Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax) As String 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 Select Case syntax
Case SQLsyntax.Db2 Case SQLsyntax.Db2
sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x" sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.SQLServer Case SQLsyntax.SqlServer
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x" sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.PostgreSQL Case SQLsyntax.PostgreSQL
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x" 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 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 i As Long
Dim j As Long Dim j As Long
@ -2374,3 +2404,87 @@ Public Function ARRAYp_get_range_string(ByRef r As range) As String()
End Function 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 load_tb As Boolean
Private set_Price As Boolean Private set_Price As Boolean
Private sp As Object Private sp As Object
Private basket() As Variant
Private bVol As Double Private bVol As Double
Private bVal As Double Private bVal As Double
@ -366,7 +367,41 @@ Private Sub UserForm_Activate()
month(0, 8) = "2020 val" month(0, 8) = "2020 val"
Me.crunch_array 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 Application.StatusBar = False
End Sub 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 On Error GoTo errh
With req With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/scenario_package", True .Open "GET", server & "/scenario_package", True
.SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Content-Type", "application/json"
.Send doc .Send doc
@ -334,10 +335,11 @@ Sub load_config()
End Sub 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 j As Object
Dim i As Integer Dim i As Integer
Dim r As Long
Dim sh As Worksheet Dim sh As Worksheet
Set sh = Sheets("_month") 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) sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
End If End If
'--json--
End If End If
Next i 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 months.load_sheet
End Sub End Sub
@ -425,3 +439,5 @@ Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
End If End If
End Function End Function

View File

@ -22,6 +22,8 @@ Private adjust() As Object
Private jtext() As Variant Private jtext() As Variant
Private basejson As Object Private basejson As Object
Private rollback As Boolean Private rollback As Boolean
Private scenario() As Variant
Private orig As Range
@ -37,6 +39,8 @@ Private Sub Worksheet_Change(ByVal target As Range)
dumping = False dumping = False
Exit Sub 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("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("F6:F17")) Is Nothing Then Call Me.mvp_set
@ -63,7 +67,11 @@ Sub mvp_set()
units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3)) units(i, 4) = units(i, 5) - (units(i, 2) + units(i, 3))
price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3)) price(i, 4) = price(i, 5) - (price(i, 2) + price(i, 3))
sales(i, 5) = units(i, 5) * price(i, 5) sales(i, 5) = units(i, 5) * price(i, 5)
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) 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) Call Me.build_json(i)
Next i Next i
@ -84,7 +92,11 @@ Sub mvp_adj()
units(i, 5) = units(i, 4) + (units(i, 2) + units(i, 3)) units(i, 5) = units(i, 4) + (units(i, 2) + units(i, 3))
price(i, 5) = price(i, 4) + (price(i, 2) + price(i, 3)) price(i, 5) = price(i, 4) + (price(i, 2) + price(i, 3))
sales(i, 5) = units(i, 5) * price(i, 5) sales(i, 5) = units(i, 5) * price(i, 5)
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3)) 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) Call Me.build_json(i)
Next i Next i
@ -102,6 +114,7 @@ Sub ms_set()
vp = Sheets("month").Range("R2") vp = Sheets("month").Range("R2")
For i = 1 To 12 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 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)) sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
Select Case vp Select Case vp
@ -154,6 +167,7 @@ Sub ms_adj()
vp = Sheets("month").Range("R2") vp = Sheets("month").Range("R2")
For i = 1 To 12 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 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) sales(i, 5) = sales(i, 4) + sales(i, 2) + sales(i, 3)
Select Case vp Select Case vp
@ -226,25 +240,37 @@ Sub set_sheet()
Range("B18:F18").FormulaR1C1 = tunits Range("B18:F18").FormulaR1C1 = tunits
Range("H18:L18").FormulaR1C1 = tprice Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales Range("N18:R18").FormulaR1C1 = tsales
Range("T6:U18").FormulaR1C1 = scenario
Sheets("month").Range("B32:Q5000").ClearContents
For i = 1 To 12 For i = 1 To 12
Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i))
Next i Next i
ActiveWindow.FreezePanes = False
Rows("19:32").Hidden = False
dumping = False dumping = False
End Sub End Sub
Sub load_sheet() Sub load_sheet()
units = Sheets("_month").Range("A2:E13").FormulaR1C1 units = Sheets("_month").Range("A2:E13").FormulaR1C1
price = Sheets("_month").Range("F2:J13").FormulaR1C1 price = Sheets("_month").Range("F2:J13").FormulaR1C1
sales = Sheets("_month").Range("K2:O13").FormulaR1C1 sales = Sheets("_month").Range("K2:O13").FormulaR1C1
scenario = Sheets("_month").Range("R1:S13").FormulaR1C1
tunits = Range("B18:F18") tunits = Range("B18:F18")
tprice = Range("H18:L18") tprice = Range("H18:L18")
tsales = Range("N18:R18") tsales = Range("N18:R18")
ReDim adjust(12) ReDim adjust(12)
Me.crunch_array Me.crunch_array
Me.set_sheet Me.set_sheet
End Sub End Sub
@ -369,7 +395,7 @@ End Sub
Sub build_json(ByVal pos As Integer) Sub build_json(ByVal pos As Integer)
'if something is changing '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)) Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson))
'if there is no existing volume on the target month but units are being added '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 If units(pos, 2) + units(pos, 3) = 0 And units(pos, 4) <> 0 Then
@ -444,5 +470,43 @@ End Sub
Sub reset() Sub reset()
Call Me.load_sheet Call Me.load_sheet
End Sub 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