work on editing basket

2019-03-19 15:43:31 -04:00 · 2019-03-19 15:43:31 -04:00 · a3d9512373
commit a3d9512373
parent 6a34f3fcf4
8 changed files with 278 additions and 72 deletions
--- 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
+
+
--- a/build.frm
+++ 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
+
+
--- a/build.frx
+++ b/build.frx
--- 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"
--- a/fpvt.frx
+++ b/fpvt.frx
--- 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
    
--- 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
+
--- a/openf.frx
+++ b/openf.frx