diff --git a/TheBigOne.cls b/TheBigOne.cls index 3b8b86e..1f25e3a 100644 --- a/TheBigOne.cls +++ b/TheBigOne.cls @@ -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 + + diff --git a/fpvt.frm b/fpvt.frm index c017f85..f698773 100644 --- a/fpvt.frm +++ b/fpvt.frm @@ -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 diff --git a/fpvt.frx b/fpvt.frx index 089b632..391548b 100644 Binary files a/fpvt.frx and b/fpvt.frx differ diff --git a/handler.bas b/handler.bas index 7bfdef9..9b9de87 100644 --- a/handler.bas +++ b/handler.bas @@ -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 + + diff --git a/months.cls b/months.cls index 330a7f4..5636d37 100644 --- a/months.cls +++ b/months.cls @@ -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 @@ -37,6 +39,8 @@ Private Sub Worksheet_Change(ByVal target As Range) dumping = False 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 @@ -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) - 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) 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) - 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) 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,25 +240,37 @@ 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") ReDim adjust(12) Me.crunch_array Me.set_sheet + + End Sub @@ -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 @@ -444,5 +470,43 @@ End Sub 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