work on editing basket

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)
-    
+    If zerobase Then
-    sh.Range(sh.Cells(row, col).Address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).Address).FormulaR1C1 = tbl
+        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
+    Dim s() As String
-    ReDim S(UBound(a, 2), UBound(a, 1))
+    ReDim s(UBound(a, 2), UBound(a, 1))
     
     Dim i As Long
     Dim j As Long
     
-    For i = 0 To UBound(S, 1)
+    For i = 0 To UBound(s, 1)
-        For j = 0 To UBound(S, 2)
+        For j = 0 To UBound(s, 2)
-            S(i, j) = a(j, i)
+            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
+    s = s & String(i, left(sNewBaseDigits, 1)) 'get the zero digits at the end of the number
-    Misc_ConvBase10 = S
+    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")
+    lcol = Me.ColumnLetter(left)
-    rcol = Me.Misc_ConvBase10(right - 1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+    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
+
+

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

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"

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
+    sh.Range("U1:AC100000").ClearContents
-    For i = 0 To UBound(basket, 2)
+    Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
-        For r = 0 To UBound(basket, 1)
+    Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
-            sh.Cells(r + 1, i + 21) = basket(r, i)
-        Next r
-    Next i
     
     months.load_sheet
     

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
+        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("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("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("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("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("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("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)
-    For i = 1 To UBound(basket, 1) - 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
+    'Rows("20:20").Select
-    ActiveWindow.FreezePanes = True
+    'ActiveWindow.FreezePanes = True
     
-    Rows("20:31").Select
+    'Rows("20:31").Select
-    Selection.EntireRow.Hidden = True
+    '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
+