work on editing basket

This commit is contained in:
Trowbridge 2019-03-19 15:43:31 -04:00
parent 6a34f3fcf4
commit a3d9512373
8 changed files with 278 additions and 72 deletions

View File

@ -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

77
build.frm Normal file
View File

@ -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

BIN
build.frx Normal file

Binary file not shown.

View File

@ -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"

BIN
fpvt.frx

Binary file not shown.

View File

@ -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

View File

@ -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

BIN
openf.frx

Binary file not shown.