From 9b8a48698143e4a6360cfca77e60b565245d2b16 Mon Sep 17 00:00:00 2001 From: Trowbridge Date: Tue, 19 Mar 2019 01:03:43 -0400 Subject: [PATCH] add functionality to display basket --- TheBigOne.cls | 182 ++++++++++++++++++++++++++++++++++++++++---------- fpvt.frm | 37 +++++++++- fpvt.frx | Bin 19992 -> 19992 bytes handler.bas | 22 +++++- months.cls | 70 ++++++++++++++++++- 5 files changed, 270 insertions(+), 41 deletions(-) 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 089b632fe0ee5055c966506daf66438e282c834e..391548bbab6fe227bb605f48088a2034b9b73378 100644 GIT binary patch delta 923 zcmZ9KUr5tY6vywqza?(kbdt4xtFgJnO>+B9oWE`ACV^W1>5qRF4vMD!putaO!}XN3 zUaZzb(vfr_g%A`NA^eo^K`5dZg$&w@6=n}b=8NzO-U3+srC}QML$Jfj;y3LjW){t z*T(YG8YFa4ZPrcET}e}tD=CSR4Hdl$!-poQq!j9hSZ+>&&&>giAy-lohM#*-@h@pO zNF0r7vu=v+N*ZIXq$G^%lo0~5shkU;9XI`g=iVYnnw_)*md!>Qf*Cd%-v%nF4T z5y#_Hl|rv&nu^Mf<-Cf;2y|O3I0@7J;$fJuF4G#ADXV~l%}r&DJ_xI}YPe(Bujnhi zD(ZqRdnZRQ{Hfi>o$j88l>I9g4Glt^@ue~$Oi!$MokvJK5Rqepk_9K}?GO^1bg;EdqMGhG>5VdXF+UFE1aRXnV^M%lm|glYpUIHxSs)>CdEJPd+h z#HK6miy4@$h9K~6L&g_`hF$ApeNvi}Ng^!!LDE`kSEVU|F;X<1Lz5Y=efpvd?kqEdO zk7Jb7sG}@GV9V`e0|Y_;;g}Tti5`~ab&qhN3|ttd1sf9ZaKx+Q2qw%n^{COFjfVSi zklN xvAvbBhLgzuLucDuW$Hp9YOR6hjjiFLo~#$4 z1toof8dCUHJ&16hd=P>NLSZlYGVIS@dN6#D9zu|y-`%ugFZZ7NoqNvt&i9?!c``ds zmJF20Fw*xVi*M9GLkaBChkSTEt4#6-v_f#c^%<+`I7_O5& zNM|aAl#D4)XjFzQH1HFnGM)>+h#Qa1J~E0mvx%I=5AzOeRvXIe-EeA-V7PvPaLR7| z6%8HFV$gDumpKkT_fgDP*6{X(1sSV^#nxKntj#2=l-v9o!ePL1nUBS@c7Q6}C4~-@wQ8^vw@HHqP;%wr_nK5FhA30}& zITdJr$(mnpuTg$C-y?@J@$#dtmh2z+2YDCa0 zt9K#=1N4jw8=fv4b5^Nc3-%Dz9@@e^3)xjk3X_CJfk~4^K4@a+a0;E8! 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