From a3d9512373f8bfcf36c5086503e9932ab1cfa11a Mon Sep 17 00:00:00 2001 From: Trowbridge Date: Tue, 19 Mar 2019 15:43:31 -0400 Subject: [PATCH] work on editing basket --- TheBigOne.cls | 76 ++++++++++++--------- build.frm | 77 +++++++++++++++++++++ build.frx | Bin 0 -> 3096 bytes fpvt.frm | 2 +- fpvt.frx | Bin 19992 -> 19992 bytes handler.bas | 9 +-- months.cls | 186 +++++++++++++++++++++++++++++++++++++++++--------- openf.frx | Bin 3096 -> 3096 bytes 8 files changed, 278 insertions(+), 72 deletions(-) create mode 100644 build.frm create mode 100644 build.frx diff --git a/TheBigOne.cls b/TheBigOne.cls index 1f25e3a..d4a45f0 100644 --- a/TheBigOne.cls +++ b/TheBigOne.cls @@ -396,7 +396,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 @@ -414,25 +414,23 @@ errhndl: 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()) +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) - - sh.Range(sh.Cells(row, col).Address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).Address).FormulaR1C1 = 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 - 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) @@ -442,19 +440,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 @@ -1430,13 +1428,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 @@ -1621,7 +1619,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 @@ -2036,7 +2034,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 @@ -2044,7 +2042,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 @@ -2256,7 +2254,7 @@ 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) @@ -2418,7 +2416,7 @@ 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 s As String, tmp As Double, i As Integer, lastI As Integer Dim BaseSize As Integer BaseSize = Len(sNewBaseDigits) Do While val(d) <> 0 @@ -2428,14 +2426,14 @@ Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As Strin 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 + 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) + 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 + 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() @@ -2479,8 +2477,9 @@ Public Function SHTp_get_block(point As Range) As Variant() 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") + lcol = Me.ColumnLetter(left) + rcol = Me.ColumnLetter(right) + 'point.row (right) Set r = Worksheets("_month").Range(lcol & top & ":" & rcol & bot) SHTp_get_block = r @@ -2488,3 +2487,18 @@ Public Function SHTp_get_block(point As Range) As Variant() 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 + + diff --git a/build.frm b/build.frm new file mode 100644 index 0000000..681d4fa --- /dev/null +++ b/build.frm @@ -0,0 +1,77 @@ +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 + canel = 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 + + diff --git a/build.frx b/build.frx new file mode 100644 index 0000000000000000000000000000000000000000..7a922ea4deeb9c6a7cbc106f69d0538b55f7c031 GIT binary patch literal 3096 zcmeHJ&ubG=5dJpVSgTQ5sU`k6MCd_8LtB5Nh>cXLR8q81@RnbtDM`0Ya}g2uBzP0? z;7RZxf+zKl=tZy|dK6K?n+HKX+V%T(H|tiYY!f^L@|M{*Z{9cW&6}AwyOY`NKoUWF zlm_~C1MgP*KR$i6|5GsGGZzrYy3>nop$UV$$ZdTe4EF8_%x8lI2PE~ajSWiBlUww1b1Hb;9KR$%KO2${ZAg_1!k`1!i&7T z`QXa^4{Ju8LR&AkS+8sPZL$i5T@ZDltY65is0y3lxWA#LbR5~S32cK{_$hyX1DELk z8Wxd50rMMhQ3iWjIKMsv3;yCg>=ifJult`MsphL5@QZ<7(hky2U$)Ed!#?lwo$CRZ zLzqY+sXQ<*dU3`bVD&VxGC*O_+&=+j?LFfSFoZAUDT}2rW+ZIE4ouib<3jwt(?0F+JV=d4;@{6UNz3h8l@su6Wt-E#nkxi$0Lp32u7Uzyy`d5VAAnR0dL zA3IyAR*y|v*s9)*xyoW>J({znX6pcFT$Oz&7IZFPjpLkKVS_l?3dnhq0pWBO50}yv z{}WHQFl)V-i<9jh?lb=uL0|mjhKi^v#VF|nDUQ9E%oobl5fAHnHH1~}2&;9?CYA!( zxunz!VKr=G6HV-K4|`7KCzhmT!1ucb938%`X0X!5S>SYo|NeGqmur<`-CDM08|lkd uy|$bl%?!I7`2UOXTA^Gjl}qVdVZK~!K-RgijNX|M{5bo1sV(#VyYg=V(Ks;x literal 0 HcmV?d00001 diff --git a/fpvt.frm b/fpvt.frm index f698773..462a11e 100644 --- a/fpvt.frm +++ b/fpvt.frm @@ -368,7 +368,7 @@ Private Sub UserForm_Activate() Me.crunch_array - ReDim basket(sp("package")("basket").Count, 4) + ReDim basket(sp("package")("basket").Count, 3) ' basket(0, 0) = "order_season" ' basket(0, 1) = "order_month" diff --git a/fpvt.frx b/fpvt.frx index 36d74dee85f9752e247aa4bf89d23fa2dbb91c06..d530870447c1cc634bc933974c750ffe4510e933 100644 GIT binary patch delta 865 zcmZ8eOH30{6rDFyLMBo^O|XRqY^~6rv{M2tm8LDGw58Y-!$*xVp+FPCLK{j~lAuu| z;{r8jAs80A!hjl**`SGR46EV_Bf$m2*0^(_hQ#=0_!%~DCg> z^z27cz&EyXdX=rduCNsr0th)EMk~DUE{-psiYSL zzne;W-n>R1?{{Azd1=M%Cm0h9q!EupXW$ST zmPntH>(hu;`F@DlF%+!8pNJmio=RAwTKYs=RJoN#qedc^Qto%-Z$}Gh#*{yXm)<%} zGW~ySa_o2^*svJ0^E67Oh7_$Kfd{T01XViBb!JFG;xB!YEo{bXIrCluzvG5~K)fp$ delta 845 zcmZ9KUr19?9LLW&cUBj4{+FPY zr;8M^qDaxTiZ2Fw0vXc?8<(+W3ecopYEH4DMy;l(5u&9?(KXADB2&<6i#9>D7Ad-B z-KJE=g}Qn+DFbysSuBnjo5CiOShLj%BT*G!Z7-;b1-qkKC4`wtBOzoDAy>L4&S%q^ zq>4qmoqDm?ah%&@>tvn`sg!8#kzwXK~`7vz@5~H=NgS z(^00In{F8dj>cnG6GyDO8Vo8)wIR@cP&c(!QzW{BNcdE2N<-pQPnKKD#-rHk4`JFZ zqGezRo9-k{=zVR6m@pm*A$Md9W3uJ%Tvph494X0-6-DO!dxu}qEY5mQ@ywUJ3eB(P z`*3KLTq ZNCWR_Mi-C0&3~bdh*hX`j^S6N?hkNfJSqSH diff --git a/handler.bas b/handler.bas index ffc0a3d..b554499 100644 --- a/handler.bas +++ b/handler.bas @@ -420,12 +420,9 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant) 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 + 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) months.load_sheet diff --git a/months.cls b/months.cls index 766d2e1..f962d79 100644 --- a/months.cls +++ b/months.cls @@ -24,30 +24,76 @@ Private basejson As Object Private rollback As Boolean Private scenario() As Variant Private orig As Range +Private basket_touch As Range -Private Sub Worksheet_Change(ByVal target As Range) +Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean) + + Dim i As Long + Dim b() As Variant + + cancel = True + If Not Intersect(Target, Range("B33:Q1000")) Is Nothing Then + build.part = Sheets("month").Cells(Target.row, 2) + build.bill = Sheets("month").Cells(Target.row, 6) + build.ship = 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) = build.cbBill.value + Sheets("month").Cells(Target.row + i, 12) = build.cbShip.value + 'Sheets("month").Cells.Rows(Target.row + i).Select + dumping = False + Set basket_touch = Selection + Call Me.get_edit_basket + + End If + + End If + +End Sub + +Private Sub Worksheet_Change(ByVal Target As Range) If Not dumping 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 + 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("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 Then + Set basket_touch = Target + Call Me.get_edit_basket + End If + + End If @@ -243,7 +289,7 @@ Sub set_sheet() Range("T6:U18").ClearContents Range("T6:U18").FormulaR1C1 = scenario - Sheets("month").Range("B32:Q5000").ClearContents + 'Sheets("month").Range("B32:Q5000").ClearContents For i = 1 To 12 Sheets("_month").Cells(i + 1, 16) = JsonConverter.ConvertToJson(adjust(i)) @@ -267,6 +313,8 @@ Sub load_sheet() tunits = Range("B18:F18") tprice = Range("H18:L18") tsales = Range("N18:R18") + 'reset basket + Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False) ReDim adjust(12) Me.crunch_array Me.set_sheet @@ -359,9 +407,9 @@ Sub set_border(ByRef targ As Range) End Sub -Sub fill_yellow(ByRef target As Range) +Sub fill_yellow(ByRef Target As Range) - With target.Interior + With Target.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 @@ -371,9 +419,9 @@ Sub fill_yellow(ByRef target As Range) End Sub -Sub fill_none(ByRef target As Range) +Sub fill_none(ByRef Target As Range) - With target.Interior + With Target.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 @@ -381,15 +429,15 @@ Sub fill_none(ByRef target As Range) End Sub -Sub format_price(ByRef target As Range) +Sub format_price(ByRef Target As Range) - target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" + Target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" End Sub -Sub format_number(ByRef target As Range) +Sub format_number(ByRef Target As Range) - target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)" + Target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)" End Sub @@ -483,31 +531,101 @@ Sub show_basket() dumping = True - Application.ScreenUpdating = False + 'Application.ScreenUpdating = False - Set orig = Selection + 'Set orig = Selection - ActiveWindow.FreezePanes = False + 'ActiveWindow.FreezePanes = False - - For i = 1 To UBound(basket, 1) - 1 + 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:20").Select - ActiveWindow.FreezePanes = True + 'Rows("20:20").Select + 'ActiveWindow.FreezePanes = True - Rows("20:31").Select - Selection.EntireRow.Hidden = True + 'Rows("20:31").Select + 'Selection.EntireRow.Hidden = True + Rows("20:31").Hidden = True + 'orig.Select - orig.Select - - Application.ScreenUpdating = True + 'Application.ScreenUpdating = True dumping = False End Sub + +Sub part_list() + + parts.Show + +End Sub + +Sub basket_pick() + + build.Show + +End Sub + +Sub get_edit_basket() + + Dim i As Long + Dim b() As Variant + Dim mix As Double + Dim touch_mix As Double + 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) + + 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 + 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 + b(i, 3) = b(i, 3) + b(i, 3) * (1 - mix) / (mix - touch_mix) + 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) + + + +End Sub + diff --git a/openf.frx b/openf.frx index 740c9ffc2a336bfea2c054e02aad152a2ee04d9c..746e8e43ab7c8d58e433c08cb621678d6111c79a 100644 GIT binary patch delta 56 zcmbOsF+*ZQ3k%zV3~l$$dz-shUNFn&F)*kwJY{5HU}a!vU}9ikumEBP21$nGB$r@c Krp*&M+L-~uYz>?M delta 56 zcmbOsF+*ZQ3kzGrvS^X1w>EdNykM69#=xM$@RX5(ft7)wfr){E!2*aG7$g~zlU#y* L88=VlXlDih+w~4c