pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Compare commits

base: pt:7e57d4621fcaaedcdce7e25535ec91ddc192cb7f
Branches Tags
pt:master
..
compare: pt:043c7264bf222ff720d5959a155e77a99c4bdf04
Branches Tags
pt:master

No commits in common. "7e57d4621fcaaedcdce7e25535ec91ddc192cb7f" and "043c7264bf222ff720d5959a155e77a99c4bdf04" have entirely different histories.
7e57d4621f ... 043c7264bf

10 changed files with 48 additions and 404 deletions
Show Stats Expand all files Collapse all files

140
TheBigOne.cls
View File

@ -459,43 +459,6 @@ Sub ARRAYp_Transpose(ByRef a() As String)
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()
@ -1498,11 +1461,11 @@ End Function
Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean
Application.EnableCancelKey = xlDisabled
MsgB.tbMSG.text = Message
MsgB.tbMSG.Text = Message
MsgB.Caption = TITLE
MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
MsgB.Show
MISC_msgbox_cancel = MsgB.Cancel
MISC_msgbox_cancel = MsgB.cancel
Application.EnableCancelKey = xlInterrupt
End Function
@ -2074,7 +2037,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
@ -2082,7 +2045,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
@ -2188,70 +2151,6 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
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
If compare < base Then
@ -2545,7 +2444,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 BaseSize As Integer
BaseSize = Len(sNewBaseDigits)
Do While val(d) <> 0
Do While Val(d) <> 0
tmp = d
i = 0
Do While tmp >= BaseSize
@ -2699,32 +2598,3 @@ Function TBLp_VarToString(ByRef t() As Variant) As String()
TBLp_VarToString = x
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

35
changes.frm
View File

@ -13,7 +13,7 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private x As Variant
Private X As Variant
Private Sub cbCancel_Click()
@ -34,7 +34,7 @@ Private Sub lbHist_Change()
For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then
Me.tbPrint.value = x(i, 7)
Me.tbPrint.value = X(i, 7)
Exit Sub
End If
Next i
@ -68,37 +68,12 @@ Private Sub UserForm_Activate()
Dim fail As Boolean
'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
Me.Hide
Exit Sub
End If
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)
Me.lbHist.list = X
End Sub
@ -116,7 +91,7 @@ Sub delete_selected()
For i = 0 To Me.lbHist.ListCount - 1
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
MsgBox ("undo did not work")
Exit Sub

BIN
changes.frx
View File

Binary file not shown.

176
fpvt.frm
View File

@ -4,7 +4,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
ClientHeight = 8445.001
ClientLeft = 120
ClientTop = 465
ClientWidth = 9285.001
ClientWidth = 8820.001
OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner
End
@ -24,11 +24,6 @@ Private load_tb As Boolean
Private set_Price As Boolean
Private sp As Object
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 bVal As Double
@ -71,9 +66,8 @@ End Sub
Private Sub butAdjust_Click()
Dim fail As Boolean
Dim doc As String
If tbAPI.text = "" Then
If adjust("source") = "" Then
MsgBox ("No adjustments provided")
Exit Sub
End If
@ -83,25 +77,7 @@ Private Sub butAdjust_Click()
Exit Sub
End If
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)
Call handler.request_adjust(JsonConverter.ConvertToJson(adjust), fail)
If fail Then
MsgBox ("adjustment was not made due to error")
Exit Sub
@ -150,24 +126,24 @@ Private Sub cbGoSheet_Click()
Worksheets("month").sbMPP.value = 0
Me.Hide
months.cbMTAG.value = ""
Worksheets("month").Visible = xlSheetVisible
Sheets("month").Select
End Sub
Private Sub cbTAG_Change()
Dim j As Object
If tbAPI.text = "" Then tbAPI.text = "{}"
Set j = JsonConverter.ParseJson(tbAPI.text)
j("tag") = cbTAG.value
tbAPI.text = JsonConverter.ConvertToJson(j)
Set adjust = JsonConverter.ParseJson(tbAPI.text)
adjust("tag") = cbTAG.value
tbAPI.text = JsonConverter.ConvertToJson(adjust)
End Sub
Private Sub Label64_Click()
End Sub
Private Sub lbMonth_Change()
@ -204,132 +180,10 @@ Private Sub lbMonth_Change()
End Sub
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
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
Private Sub lheader_Click()
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()
opPlugVol.Enabled = False
@ -570,7 +424,6 @@ Private Sub UserForm_Activate()
Me.lheader = "Loading..."
Set sp = handler.scenario_package("{""scenario"":" & scenario & "}", ok)
Call x.frmListBoxHeader(Me.lbSHDR, Me.lbSDET, "Field", "Selection")
Me.lheader = "Ready"
@ -726,17 +579,10 @@ Private Sub UserForm_Activate()
End If
'----------reset spinner buttons----------------------
sbpv.value = 0
sbpd.value = 0
sbpp.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)
Application.StatusBar = False

BIN
fpvt.frx
View File

Binary file not shown.

58
handler.bas
View File

@ -5,7 +5,7 @@ Public sql As String
Public jsql As String
Public scenario As String
Public sc() As Variant
Public x As New TheBigOne
Public X As New TheBigOne
Public wapi As New Windows_API
Public data() As String
Public agg() As String
@ -26,7 +26,7 @@ Sub load_fpvt()
Dim i As Long
Dim s_tot As Object
fpvt.lbSDET.list = handler.sc
fpvt.ListBox1.list = handler.sc
showprice = False
@ -182,7 +182,7 @@ Sub pg_main_workset(rep As String)
ReDim str(UBound(res, 1), UBound(res, 2))
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
@ -309,7 +309,7 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
i = i + 1
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)
@ -453,8 +453,8 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
'basket
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)
Call X.SHTp_DumpVar(basket, "_month", 1, 21, False, False, True)
Call X.SHTp_DumpVar(basket, "_month", 1, 26, False, False, True)
Sheets("config").Cells(5, 2) = 0
Sheets("config").Cells(6, 2) = 0
Sheets("config").Cells(7, 2) = 0
@ -589,49 +589,3 @@ Sub history()
changes.Show
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

37
months.cls
View File

@ -9,7 +9,7 @@ Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private x As New TheBigOne
Private X As New TheBigOne
Private units() As Variant
Private price() As Variant
Private sales() As Variant
@ -34,7 +34,7 @@ Private did_load_config As Boolean
Private Sub cbMTAG_Change()
End Sub
@ -126,11 +126,11 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If
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
Cancel = True
cancel = True
Call Me.basket_pick(Target)
Target.Select
End If
@ -146,10 +146,10 @@ Sub picker_shortcut()
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
Cancel = True
cancel = True
Call Me.basket_pick(Target)
Target.Select
End If
@ -361,7 +361,7 @@ Sub set_sheet()
Range("H18:L18").FormulaR1C1 = tprice
Range("N18:R18").FormulaR1C1 = tsales
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
If Me.newpart Then
@ -388,7 +388,7 @@ Sub load_sheet()
tsales = Range("N18:R18")
'reset basket
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)
Call Me.crunch_array
Call Me.set_sheet
@ -558,7 +558,6 @@ Sub build_json()
Set np("scenario")("iter") = JsonConverter.ParseJson("[""copy""]")
np("source") = "adj"
np("type") = "new_basket"
np("tag") = cbMTAG.text
Set m = JsonConverter.ParseJson("{}")
End If
@ -620,9 +619,9 @@ Sub build_json()
'np("basket") = x.json_from_table(b, "basket", False)
'get the basket from the sheet
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
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
Set np("basket") = m("basket")
End If
@ -687,7 +686,7 @@ Sub crunch_array()
End Sub
Sub Cancel()
Sub cancel()
Sheets("Orders").Select
@ -727,7 +726,7 @@ Sub print_basket()
Dim i As Long
Dim basket() As Variant
basket = x.SHTp_get_block(Sheets("_month").Range("U1"))
basket = X.SHTp_get_block(Sheets("_month").Range("U1"))
dumping = True
@ -840,7 +839,7 @@ Sub get_edit_basket()
dumping = False
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
Me.build_json
@ -911,7 +910,7 @@ Sub build_new()
'Call Me.set_sheet
'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, 6) = basket(1, 2)
Sheets("month").Cells(32, 12) = basket(1, 3)
@ -934,8 +933,8 @@ Sub new_part()
'---------build customer mix-------------------------------------------------------------------
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
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
MsgBox ("error building customer mix")
End If
@ -979,8 +978,8 @@ Sub new_part()
i = i + 1
Loop
Worksheets("_month").Range("U2:AC10000").ClearContents
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, 21, False, False, True)
Call X.SHTp_DumpVar(b, "_month", 2, 26, False, False, True)
'------reset volume to copy base to forecsat and clear base------------------------------------

BIN
openf.frx
View File

Binary file not shown.

BIN
part.frx
View File

Binary file not shown.

6
pivot.cls
View File

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