Compare commits

..

2 Commits

Author SHA1 Message Date
Trowbridge
7e57d4621f add a new route for swapping out parts 2020-03-05 01:08:10 -05:00
pt
f569e6238d version 1.4 2020-03-03 23:22:13 -05:00
10 changed files with 404 additions and 48 deletions

View File

@ -459,6 +459,43 @@ Sub ARRAYp_Transpose(ByRef a() As String)
End Sub End Sub
Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant()
Dim s() As Variant
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)
Next j
Next i
ARRAYp_TransposeVar = s
End Function
Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant()
Dim i As Long
Dim j As Long
Dim r() As Variant
ReDim r(UBound(z, 1), UBound(z, 2) + 1)
For i = 0 To UBound(r, 1)
For j = 1 To UBound(r, 2)
r(i, j) = z(i, j - 1)
Next j
r(i, 0) = cols(i)
Next i
ARRAYp_zerobased_addheader = r
End Function
Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String() Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String()
@ -1461,11 +1498,11 @@ End Function
Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean
Application.EnableCancelKey = xlDisabled Application.EnableCancelKey = xlDisabled
MsgB.tbMSG.Text = Message MsgB.tbMSG.text = Message
MsgB.Caption = TITLE MsgB.Caption = TITLE
MsgB.tbMSG.ScrollBars = fmScrollBarsBoth MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
MsgB.Show MsgB.Show
MISC_msgbox_cancel = MsgB.cancel MISC_msgbox_cancel = MsgB.Cancel
Application.EnableCancelKey = xlInterrupt Application.EnableCancelKey = xlInterrupt
End Function End Function
@ -2037,7 +2074,7 @@ Function json_concat(list As Range) As String
End Function 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 Dim i As Long
@ -2045,7 +2082,7 @@ Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, target As String, tri
Dim sql As String Dim sql As String
Dim rec As String Dim rec As String
sql = "INSERT INTO " & target & " VALUES " & vbCrLf sql = "INSERT INTO " & Target & " VALUES " & vbCrLf
For i = start To ending For i = start To ending
rec = "" rec = ""
If i <> start Then sql = sql & "," & vbCrLf If i <> start Then sql = sql & "," & vbCrLf
@ -2151,6 +2188,70 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
End Function End Function
Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 1 To UBound(tbl, 1)
For c = 0 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 1 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
If r > 2 Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table_zb = ajson
End Function
Public Function MISCe_MaxLng(ByRef base As Long, ByRef compare As Long) As Long Public Function MISCe_MaxLng(ByRef base As Long, ByRef compare As Long) As Long
If compare < base Then If compare < base Then
@ -2444,7 +2545,7 @@ Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As Strin
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 Dim BaseSize As Integer
BaseSize = Len(sNewBaseDigits) BaseSize = Len(sNewBaseDigits)
Do While Val(d) <> 0 Do While val(d) <> 0
tmp = d tmp = d
i = 0 i = 0
Do While tmp >= BaseSize Do While tmp >= BaseSize
@ -2598,3 +2699,32 @@ Function TBLp_VarToString(ByRef t() As Variant) As String()
TBLp_VarToString = x TBLp_VarToString = x
End Function End Function
Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
Dim i As Long
hdr.ColumnCount = det.ColumnCount
hdr.ColumnWidths = det.ColumnWidths
' add header elements
hdr.clear
hdr.AddItem
For i = 0 To UBound(cols, 1)
hdr.list(0, i) = cols(i)
Next i
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
hdr.SpecialEffect = fmSpecialEffectFlat
'hdr.BackColor = RGB(200, 200, 200)
hdr.Height = 10
' align header to body (should be done last!)
hdr.width = det.width
hdr.Left = det.Left
hdr.Top = det.Top - (hdr.Height - 1)
End Sub

View File

@ -13,7 +13,7 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False Attribute VB_Exposed = False
Private X As Variant Private x As Variant
Private Sub cbCancel_Click() Private Sub cbCancel_Click()
@ -34,7 +34,7 @@ Private Sub lbHist_Change()
For i = 0 To Me.lbHist.ListCount - 1 For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then If Me.lbHist.Selected(i) Then
Me.tbPrint.value = X(i, 7) Me.tbPrint.value = x(i, 7)
Exit Sub Exit Sub
End If End If
Next i Next i
@ -68,12 +68,37 @@ Private Sub UserForm_Activate()
Dim fail As Boolean Dim fail As Boolean
'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail) 'x = handler.list_changes("{""user"":""" & Application.UserName & """}", fail)
X = handler.list_changes("{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}", fail) x = handler.list_changes("{""quota_rep_descr"":""" & Sheets("data").Cells(2, 5) & """}", fail)
If fail Then If fail Then
Me.Hide Me.Hide
Exit Sub Exit Sub
End If End If
Me.lbHist.list = X Me.lbHist.list = x
lbHEAD.ColumnCount = lbHist.ColumnCount
lbHEAD.ColumnWidths = lbHist.ColumnWidths
' add header elements
lbHEAD.clear
lbHEAD.AddItem
lbHEAD.list(0, 0) = "Modifier"
lbHEAD.list(0, 1) = "Owner"
lbHEAD.list(0, 2) = "When"
lbHEAD.list(0, 3) = "Tag"
lbHEAD.list(0, 4) = "Comment"
lbHEAD.list(0, 5) = "Sales"
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
'lbHEAD.SpecialEffect = fmSpecialEffectFlat
'lbHEAD.BackColor = RGB(200, 200, 200)
lbHEAD.Height = 10
' align header to body (should be done last!)
lbHEAD.width = lbHist.width
lbHEAD.Left = lbHist.Left
lbHEAD.Top = lbHist.Top - (lbHEAD.Height - 1)
End Sub End Sub
@ -91,7 +116,7 @@ Sub delete_selected()
For i = 0 To Me.lbHist.ListCount - 1 For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then If Me.lbHist.Selected(i) Then
Call handler.undo_changes(X(i, 6), fail) Call handler.undo_changes(x(i, 6), fail)
If fail Then If fail Then
MsgBox ("undo did not work") MsgBox ("undo did not work")
Exit Sub Exit Sub

Binary file not shown.

176
fpvt.frm
View File

@ -4,7 +4,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
ClientHeight = 8445.001 ClientHeight = 8445.001
ClientLeft = 120 ClientLeft = 120
ClientTop = 465 ClientTop = 465
ClientWidth = 8820.001 ClientWidth = 9285.001
OleObjectBlob = "fpvt.frx":0000 OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner StartUpPosition = 1 'CenterOwner
End End
@ -24,6 +24,11 @@ Private load_tb As Boolean
Private set_Price As Boolean Private set_Price As Boolean
Private sp As Object Private sp As Object
Private basket() As Variant Private basket() As Variant
Private vSwap() As Variant
Private swapline As Integer
Private set_swapalt As Boolean
Private return_swap As Boolean
Private jswap As Object
Private bVol As Double Private bVol As Double
Private bVal As Double Private bVal As Double
@ -66,8 +71,9 @@ End Sub
Private Sub butAdjust_Click() Private Sub butAdjust_Click()
Dim fail As Boolean Dim fail As Boolean
Dim doc As String
If adjust("source") = "" Then If tbAPI.text = "" Then
MsgBox ("No adjustments provided") MsgBox ("No adjustments provided")
Exit Sub Exit Sub
End If End If
@ -77,7 +83,25 @@ Private Sub butAdjust_Click()
Exit Sub Exit Sub
End If End If
Call handler.request_adjust(JsonConverter.ConvertToJson(adjust), fail) Select Case fpvt.mp.SelectedItem.Name
Case "pageSWAP"
doc = tbAPI.text
If doc = "" Then
MsgBox ("no part swap setup")
Exit Sub
End If
Case "pAnn"
doc = tbAPI.text
If doc = "" Then
MsgBox ("no adjustements are ready")
Exit Sub
End If
Case Else
MsgBox ("not on an adjustable tab")
Exit Sub
End Select
Call handler.request_adjust(doc, fail)
If fail Then If fail Then
MsgBox ("adjustment was not made due to error") MsgBox ("adjustment was not made due to error")
Exit Sub Exit Sub
@ -126,24 +150,24 @@ Private Sub cbGoSheet_Click()
Worksheets("month").sbMPP.value = 0 Worksheets("month").sbMPP.value = 0
Me.Hide Me.Hide
months.cbMTAG.value = ""
Worksheets("month").Visible = xlSheetVisible Worksheets("month").Visible = xlSheetVisible
Sheets("month").Select Sheets("month").Select
End Sub End Sub
Private Sub cbTAG_Change() Private Sub cbTAG_Change()
Dim j As Object
If tbAPI.text = "" Then tbAPI.text = "{}" If tbAPI.text = "" Then tbAPI.text = "{}"
Set adjust = JsonConverter.ParseJson(tbAPI.text) Set j = JsonConverter.ParseJson(tbAPI.text)
adjust("tag") = cbTAG.value j("tag") = cbTAG.value
tbAPI.text = JsonConverter.ConvertToJson(adjust) tbAPI.text = JsonConverter.ConvertToJson(j)
End Sub End Sub
Private Sub Label64_Click()
End Sub
Private Sub lbMonth_Change() Private Sub lbMonth_Change()
@ -180,10 +204,132 @@ Private Sub lbMonth_Change()
End Sub End Sub
Private Sub lheader_Click() Private Sub cbPLIST_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode <> 13 Then Exit Sub
Dim i As Long
If set_swapalt Then Exit Sub
Dim vtable() As Variant
Dim ptable As String
Dim rx As Object
Set rx = CreateObject("vbscript.regexp")
rx.Global = True
rx.Pattern = " - .*"
For i = 0 To Me.lbSWAP.ListCount - 1
If Me.lbSWAP.Selected(i) Then
vSwap(swapline, 2) = rx.Replace(cbPLIST.value, "")
return_swap = True
lbSWAP.list = vSwap
return_swap = False
End If
Next i
vtable = x.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", False)
Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan
jswap("scenario")("iter") = handler.basis
jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
jswap("user") = Application.UserName
jswap("source") = "adj"
jswap("message") = tbCOM.text
jswap("tag") = cbTAG.text
jswap("type") = "swap"
tbAPI.text = JsonConverter.ConvertToJson(jswap)
End Sub End Sub
Private Sub dbGETSWAP_Click()
Dim doc As String
Dim j As Object
Dim fail As Boolean
Dim l() As Variant
Dim ptable As String
Dim vtable() As Variant
Set j = JsonConverter.ParseJson("{""scenario"":" & handler.scenario & "}")
'Set j = JsonConverter.ParseJson(doc)
j("new_mold") = pickSWAP.text
doc = JsonConverter.ConvertToJson(j)
vSwap = handler.get_swap_fit(doc, fail)
lbSWAP.list = vSwap
'Call x.frmListBoxHeader(lbSWAPH, lbSWAP, "Original", "Sales", "Replacement", "Fit")
cbPLIST.list = Application.transpose(Worksheets("mdata").Range("A2:A26267"))
'---------build change-------------
Set jswap = j
vtable = x.ARRAYp_TransposeVar(vSwap)
vtable = x.ARRAYp_zerobased_addheader(vtable, "original", "sales", "replace", "fit")
vtable = x.ARRAYp_TransposeVar(vtable)
ptable = x.json_from_table_zb(vtable, "rows", False)
Set jswap("swap") = JsonConverter.ParseJson(ptable)
jswap("scenario")("version") = handler.plan
jswap("scenario")("iter") = handler.basis
jswap("stamp") = Format(Date + time, "yyyy-mm-dd hh:mm:ss")
jswap("user") = Application.UserName
jswap("source") = "adj"
jswap("message") = tbCOM.text
jswap("tag") = cbTAG.text
jswap("type") = "swap"
tbAPI.text = JsonConverter.ConvertToJson(jswap)
End Sub
Private Sub lbSWAP_Change()
Dim i As Long
If return_swap Then Exit Sub
For i = 0 To Me.lbSWAP.ListCount - 1
If Me.lbSWAP.Selected(i) Then
set_swapalt = True
cbPLIST.value = vSwap(i, 2)
set_swapalt = False
swapline = i
End If
Next i
End Sub
Private Sub lbSWAP_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' Dim rx As Object
' Set rx = CreateObject("vbscript.regexp")
' rx.Global = True
' rx.Pattern = " - .*"
' Dim match As Object
' Dim i As Long
' Dim v As Variant
'
' 'v = Me.lbSWAP.list
'
' For i = 0 To Me.lbSWAP.ListCount - 1
' If Me.lbSWAP.Selected(i) Then
' part.Show
' If Not part.useval Then
' Exit Sub
' End If
' 'vSwap(i, 3) = rx.Execute(part.cbPart.value)
' 'v(i, 2) = rx.Replace(part.cbPart.value, "")
' 'Me.lbSWAP.list = v
' End If
' Next i
'
End Sub
Private Sub opEditPrice_Click() Private Sub opEditPrice_Click()
opPlugVol.Enabled = False opPlugVol.Enabled = False
@ -424,6 +570,7 @@ Private Sub UserForm_Activate()
Me.lheader = "Loading..." Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok) Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
Call x.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.lheader = "Ready" Me.lheader = "Ready"
@ -579,10 +726,17 @@ Private Sub UserForm_Activate()
End If End If
'----------reset spinner buttons---------------------- '----------reset spinner buttons----------------------
sbpd.value = 0 sbpv.value = 0
sbpp.value = 0 sbpp.value = 0
sbpd.value = 0 sbpd.value = 0
'--------reset swap tab-------------------------------
lbSWAP.clear
pickSWAP.value = ""
pickSWAP.text = ""
pickSWAP.list = Application.transpose(Worksheets("mdata").Range("F2:F1672"))
Call x.frmListBoxHeader(Me.lbSWAPH, Me.lbSWAP, "Original", "Sales", "Replacement", "Fit")
Call handler.month_tosheet(month, basket) Call handler.month_tosheet(month, basket)
Application.StatusBar = False Application.StatusBar = False

BIN
fpvt.frx

Binary file not shown.

View File

@ -5,7 +5,7 @@ Public sql As String
Public jsql As String Public jsql As String
Public scenario As String Public scenario As String
Public sc() As Variant Public sc() As Variant
Public X As New TheBigOne Public x As New TheBigOne
Public wapi As New Windows_API Public wapi As New Windows_API
Public data() As String Public data() As String
Public agg() As String Public agg() As String
@ -26,7 +26,7 @@ Sub load_fpvt()
Dim i As Long Dim i As Long
Dim s_tot As Object Dim s_tot As Object
fpvt.ListBox1.list = handler.sc fpvt.lbSDET.list = handler.sc
showprice = False showprice = False
@ -182,7 +182,7 @@ Sub pg_main_workset(rep As String)
ReDim str(UBound(res, 1), UBound(res, 2)) ReDim str(UBound(res, 1), UBound(res, 2))
Worksheets("data").Cells.ClearContents Worksheets("data").Cells.ClearContents
Call X.SHTp_DumpVar(res, "data", 1, 1, False, True, True) Call x.SHTp_DumpVar(res, "data", 1, 1, False, True, True)
End Sub End Sub
@ -309,7 +309,7 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
i = i + 1 i = i + 1
Loop Loop
Call X.SHTp_DumpVar(res, "data", i, 1, False, False, True) Call x.SHTp_DumpVar(res, "data", i, 1, False, False, True)
'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32) 'Call x.SHTp_Dump(str, "data", CLng(i), 1, False, False, 28, 29, 30, 31, 32)
@ -453,8 +453,8 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
'basket 'basket
sh.Range("U1:AC100000").ClearContents sh.Range("U1:AC100000").ClearContents
Call X.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True) Call x.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
Call X.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True) Call x.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
Sheets("config").Cells(5, 2) = 0 Sheets("config").Cells(5, 2) = 0
Sheets("config").Cells(6, 2) = 0 Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 2) = 0 Sheets("config").Cells(7, 2) = 0
@ -589,3 +589,49 @@ Sub history()
changes.Show changes.Show
End Sub End Sub
Function get_swap_fit(doc As String, ByRef fail As Boolean) As Variant()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
Dim i As Integer
Dim j As Integer
Dim res() As Variant
If doc = "" Then
fail = True
Exit Function
End If
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", server & "/swap_fit", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
If IsNull(json("x")) Then
MsgBox ("no history")
fail = True
Exit Function
End If
ReDim res(json("x").Count - 1, 3)
For i = 0 To UBound(res, 1)
res(i, 0) = json("x")(i + 1)("part")
res(i, 1) = json("x")(i + 1)("value_usd")
res(i, 2) = json("x")(i + 1)("swap")
res(i, 3) = json("x")(i + 1)("fit")
Next i
get_swap_fit = res
End Function

View File

@ -9,7 +9,7 @@ Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True Attribute VB_Exposed = True
Option Explicit Option Explicit
Private X As New TheBigOne Private x As New TheBigOne
Private units() As Variant Private units() As Variant
Private price() As Variant Private price() As Variant
Private sales() As Variant Private sales() As Variant
@ -126,11 +126,11 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If End If
End Sub End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
End If End If
@ -146,10 +146,10 @@ Sub picker_shortcut()
End Sub End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, cancel As Boolean) Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True Cancel = True
Call Me.basket_pick(Target) Call Me.basket_pick(Target)
Target.Select Target.Select
End If End If
@ -361,7 +361,7 @@ Sub set_sheet()
Range("H18:L18").FormulaR1C1 = tprice Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales Range("N18:R18").FormulaR1C1 = tsales
Range("T6:U18").ClearContents Range("T6:U18").ClearContents
Call X.SHTp_DumpVar(X.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False)
'Sheets("month").Range("B32:Q5000").ClearContents 'Sheets("month").Range("B32:Q5000").ClearContents
If Me.newpart Then If Me.newpart Then
@ -388,7 +388,7 @@ Sub load_sheet()
tsales = Range("N18:R18") tsales = Range("N18:R18")
'reset basket 'reset basket
Sheets("_month").Range("U1:X10000").ClearContents Sheets("_month").Range("U1:X10000").ClearContents
Call X.SHTp_DumpVar(X.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False) Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("Z1")), "_month", 1, 21, False, False, False)
ReDim adjust(12) ReDim adjust(12)
Call Me.crunch_array Call Me.crunch_array
Call Me.set_sheet Call Me.set_sheet
@ -558,6 +558,7 @@ Sub build_json()
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]") Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj" np("source") = "adj"
np("type") = "new_basket" np("type") = "new_basket"
np("tag") = cbMTAG.text
Set m = JsonConverter.ParseJson("{}") Set m = JsonConverter.ParseJson("{}")
End If End If
@ -619,9 +620,9 @@ Sub build_json()
'np("basket") = x.json_from_table(b, "basket", False) 'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet 'get the basket from the sheet
b = Worksheets("_month").Range("U1").CurrentRegion.value b = Worksheets("_month").Range("U1").CurrentRegion.value
Set m = JsonConverter.ParseJson(X.json_from_table(b, "basket", False)) Set m = JsonConverter.ParseJson(x.json_from_table(b, "basket", False))
If UBound(b, 1) <= 2 Then If UBound(b, 1) <= 2 Then
Set np("basket") = JsonConverter.ParseJson("[" & X.json_from_table(b, "basket", False) & "]") Set np("basket") = JsonConverter.ParseJson("[" & x.json_from_table(b, "basket", False) & "]")
Else Else
Set np("basket") = m("basket") Set np("basket") = m("basket")
End If End If
@ -686,7 +687,7 @@ Sub crunch_array()
End Sub End Sub
Sub cancel() Sub Cancel()
Sheets("Orders").Select Sheets("Orders").Select
@ -726,7 +727,7 @@ Sub print_basket()
Dim i As Long Dim i As Long
Dim basket() As Variant Dim basket() As Variant
basket = X.SHTp_get_block(Sheets("_month").Range("U1")) basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
dumping = True dumping = True
@ -839,7 +840,7 @@ Sub get_edit_basket()
dumping = False dumping = False
Worksheets("_month").Range("U2:X5000").ClearContents Worksheets("_month").Range("U2:X5000").ClearContents
Call X.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
If Me.newpart Then If Me.newpart Then
Me.build_json Me.build_json
@ -910,7 +911,7 @@ Sub build_new()
'Call Me.set_sheet 'Call Me.set_sheet
'Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False) 'Call x.SHTp_DumpVar(x.SHTp_get_block(Worksheets("_month").Range("R1")), "month", 6, 20, False, False, False)
basket = X.SHTp_get_block(Worksheets("_month").Range("U1")) basket = x.SHTp_get_block(Worksheets("_month").Range("U1"))
Sheets("month").Cells(32, 2) = basket(1, 1) Sheets("month").Cells(32, 2) = basket(1, 1)
Sheets("month").Cells(32, 6) = basket(1, 2) Sheets("month").Cells(32, 6) = basket(1, 2)
Sheets("month").Cells(32, 12) = basket(1, 3) Sheets("month").Cells(32, 12) = basket(1, 3)
@ -933,8 +934,8 @@ Sub new_part()
'---------build customer mix------------------------------------------------------------------- '---------build customer mix-------------------------------------------------------------------
cust = X.SHTp_Get("_month", 1, 27, True) cust = x.SHTp_Get("_month", 1, 27, True)
If Not X.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then If Not x.TBLp_Aggregate(cust, True, True, True, Array(0, 1), Array("S", "S"), Array(2)) Then
MsgBox ("error building customer mix") MsgBox ("error building customer mix")
End If End If
@ -978,8 +979,8 @@ Sub new_part()
i = i + 1 i = i + 1
Loop Loop
Worksheets("_month").Range("U2:AC10000").ClearContents Worksheets("_month").Range("U2:AC10000").ClearContents
Call X.SHTp_DumpVar(b, "_month", 2, 21, False, False, True) Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
Call X.SHTp_DumpVar(b, "_month", 2, 26, False, False, True) Call x.SHTp_DumpVar(b, "_month", 2, 26, False, False, True)
'------reset volume to copy base to forecsat and clear base------------------------------------ '------reset volume to copy base to forecsat and clear base------------------------------------

BIN
openf.frx

Binary file not shown.

BIN
part.frx

Binary file not shown.

View File

@ -13,9 +13,9 @@ Private Sub Worksheet_Activate()
End Sub End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then
Exit Sub Exit Sub
End If End If
@ -25,7 +25,7 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean
Exit Sub Exit Sub
End If End If
cancel = True Cancel = True
Dim i As Long Dim i As Long
Dim j As Long Dim j As Long