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

Compare commits

base: pt:cc4bd12720661c8823e6e2e6a7a673d19c4f2036
Branches Tags
pt:master
..
compare: pt:d10a15f1133a8962adeb72068546d1b711e7d3dd
Branches Tags
pt:master

No commits in common. "cc4bd12720661c8823e6e2e6a7a673d19c4f2036" and "d10a15f1133a8962adeb72068546d1b711e7d3dd" have entirely different histories.
cc4bd12720 ... d10a15f113

2 changed files with 21 additions and 395 deletions
Show Stats Expand all files Collapse all files

367
FL.bas
View File

@ -1,5 +1,4 @@
Attribute VB_Name = "FL"
Option Explicit
Public price_sheet As Worksheet
@ -420,7 +419,6 @@ End Sub
Sub PastValues()
Attribute PastValues.VB_ProcData.VB_Invoke_Func = "V\n14"
On Error GoTo errh
Call Selection.PasteSpecial(xlPasteValues, xlNone, False, False)
@ -433,7 +431,6 @@ End Sub
Sub CollapsePvtItem()
Attribute CollapsePvtItem.VB_ProcData.VB_Invoke_Func = "Z\n14"
On Error GoTo show_det
ActiveCell.PivotItem.DrilledDown = False
@ -462,7 +459,6 @@ End Sub
Sub ExpandPvtItem()
Attribute ExpandPvtItem.VB_ProcData.VB_Invoke_Func = "X\n14"
On Error GoTo show_det
ActiveCell.PivotItem.DrilledDown = True
@ -491,7 +487,6 @@ End Sub
Sub CollapsePvtFld()
Attribute CollapsePvtFld.VB_ProcData.VB_Invoke_Func = "A\n14"
On Error GoTo show_det
ActiveCell.PivotField.DrilledDown = False
@ -521,7 +516,6 @@ End Sub
Sub ExpandPvtFld()
Attribute ExpandPvtFld.VB_ProcData.VB_Invoke_Func = "S\n14"
On Error GoTo show_det
ActiveCell.PivotField.DrilledDown = True
@ -602,10 +596,6 @@ Sub SetPivotShortcutKeys()
Call Application.MacroOptions("PERSONAL.xlsb!CollapsePvtItem", "", , , , "Z")
Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtFld", "", , , , "S")
Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtItem", "", , , , "X")
Call Application.MacroOptions("PERSONAL.xlsb!PastValues", "", , , , "V")
Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format", "", , , , "F")
Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format_3dec", "", , , , "N")
Call Application.MacroOptions("PERSONAL.xlsb!pivot_field_format_1dec", "", , , , "M")
End Sub
@ -713,13 +703,6 @@ Attribute pivot_field_format_3dec.VB_ProcData.VB_Invoke_Func = "N\n14"
End Sub
Sub pivot_field_format_1dec()
Attribute pivot_field_format_1dec.VB_ProcData.VB_Invoke_Func = "M\n14"
ActiveSheet.PivotTables(1).PivotFields(ActiveCell.value).NumberFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""???_);_(@_)"
End Sub
Sub Write_selection()
Dim P As FileDialog
@ -981,9 +964,9 @@ Sub extract_price_matrix()
Select Case cms_pl(i, 13)
Case ""
Case "no unit conversion"
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
Case "no part number"
'orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(220, 220, 220)
'orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
End Select
Next i
@ -1164,14 +1147,14 @@ Sub extract_price_matrix_r1()
For i = 1 To UBound(cms_pl, 1)
Select Case cms_pl(i, 13)
Case ""
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor = xlThemeColorAccent6
Case "no unit conversion"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
End If
Case "no part number"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
End If
End Select
Next i
@ -1202,217 +1185,6 @@ Sub extract_price_matrix_r1()
End Sub
Sub extract_price_matrix_r2()
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl() As Variant
Dim unp() As String
Dim unv() As Variant
Dim unps() As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim cms_pl() As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
'------------------------------------selection-------------------------------------------------
Set orig = Application.Selection
Selection.CurrentRegion.Select
Set orig = Application.Selection
'--------------------------------test if valid price matrix------------------------------
If Selection.Cells.Count = 1 Then
MsgBox ("selection is not a table")
orig.Select
Exit Sub
End If
tbl = Selection
If UBound(tbl, 1) < 2 Then error = "selection is not a valid price matrix"
If UBound(tbl, 2) < 9 Then error = "selection is not a valid price matrix"
If Not error = "" Then
MsgBox (error)
Exit Sub
End If
'-----------------------------unpivot price matrix into new array-----------------------------
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
k = 0
ReDim unp(9, (UBound(tbl, 1) - 1) * 3)
'iterate through rows
For i = 2 To UBound(tbl, 1)
'3 iterations per row
For m = 0 To 2
k = k + 1
'part
unp(0, k) = tbl(i, 1) 'stlye code
unp(1, k) = tbl(i, 2) 'color tier
unp(2, k) = tbl(i, 3) 'branding
unp(3, k) = tbl(i, 4) 'kit
unp(4, k) = tbl(i, 5) 'suffix
unp(5, k) = tbl(i, 6) 'container
unp(6, k) = m + 1 'volume break
unp(7, k) = tbl(i, 7 + m) 'price
unp(8, k) = i 'orig row
unp(9, k) = 7 + m 'orig col
Next m
Next i
unp(0, 0) = "stlc"
unp(1, 0) = "coltier"
unp(2, 0) = "branding"
unp(3, 0) = "kit"
unp(4, 0) = "suffix"
unp(5, 0) = "container"
unp(6, 0) = "volume"
unp(7, 0) = "price"
unp(8, 0) = "orig_row"
unp(9, 0) = "orig_col"
If Not x.TBLp_TestNumeric(unp, 7) Then
MsgBox ("price is text")
Exit Sub
End If
unp = x.TBLp_Transpose(unp)
unv = x.TBLp_StringToVar(unp)
'-------------------------prepare sql to upload---------------------------------------------------------------
'sql = x.SQLp_build_sql_values(unp, False, True, Db2, False)
sql = x.json_from_table(unv, "", False)
sql = "SELECT * FROM rlarp.build_pricelist_r1($$" & sql & "$$::jsonb)"
Call wapi.ClipBoard_SetData(sql)
'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
login.Show
If Not login.proceed Then Exit Sub
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, login.tbU.Text, login.tbP.Text, "Port=5030;Database=ubm") Then
MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
Exit Sub
End If
cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True)
Call x.ADOp_CloseCon(0)
'--------------------------setup an output sheet if necessary-------------------------------
For Each ws In Application.Worksheets
For Each cp In ws.CustomProperties
If cp.Name = "spec_name" And cp.value = "price_list" Then
Set new_sh = ws
Exit For
End If
Next cp
Next ws
If new_sh Is Nothing Then
Set new_sh = Application.Worksheets.Add
Call new_sh.CustomProperties.Add("spec_name", "price_list")
new_sh.Name = "Price Build"
End If
'-------------------------dump contents------------------------------------------------------
Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True)
new_sh.Select
ActiveSheet.Cells(1, 1).CurrentRegion.Select
Selection.Columns.AutoFit
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'--------------------------format source cells for any build issues--------------------------------
orig.Worksheet.Select
With orig.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'if a cell has even one valid hit, don't show an error
'create a copy of tbl
'the default value for cell is error, if any good values are found, they stay
j = 0
For i = 1 To UBound(cms_pl, 1)
Select Case cms_pl(i, 15)
Case ""
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
Case "no unit conversion"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
End If
Case "no part number"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
End If
End Select
'if the current row/column is OK, advance to the next row/column
j = 0
Do Until cms_pl(i, 13) <> cms_pl(i + j, 13) Or cms_pl(i, 14) <> cms_pl(i + j, 14)
j = j + 1
If i + j >= UBound(cms_pl, 1) Then Exit Do
Loop
i = i + j - 1 '-1 becuase the "next i" will increment by 1 again
Next i
Dim cell As Range
For Each cell In Application.Selection.Cells
'if the cell fill is green, then a known good part was found, so cell to blank
If cell.Interior.ThemeColor = xlThemeColorAccent6 Then
cell.Interior.Pattern = xlNone
Else
If cell.Interior.Pattern = xlNone And cell.value <> "" Then
cell.Interior.Color = RGB(255, 255, 161)
End If
End If
'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed
Next cell
Selection.Columns(1).Interior.Pattern = xlNone
Selection.Columns(2).Interior.Pattern = xlNone
Selection.Columns(3).Interior.Pattern = xlNone
Selection.Columns(4).Interior.Pattern = xlNone
Selection.Columns(5).Interior.Pattern = xlNone
Selection.Columns(6).Interior.Pattern = xlNone
Selection.Rows(1).Interior.Pattern = xlNone
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
End Sub
Sub go_to_price_issue()
Dim ws As Worksheet
@ -1574,128 +1346,3 @@ PRICELIST_SHOW:
End Sub
Sub build_price_upload_r2()
Dim x As New TheBigOne
Dim pl() As String
Dim plv() As Variant
Dim i As Long
Dim j As Long
Dim ul() As String
Dim pl_code As String
Dim pl_action As String
Dim dtl_action As String
Dim pl_d1 As String
Dim pl_d2 As String
Dim pl_d3 As String
Dim fd As FileDialog
Dim ulsql As String
Dim temp() As String
Dim wapi As New Windows_API
pl = x.SHTp_GetString(Selection)
ReDim ul(11, UBound(pl, 2))
PRICELIST_SHOW:
Call pricelist.load_lists
pricelist.Show
If Not pricelist.proceed Then Exit Sub
pl_code = pricelist.cbLIST.value
pl_d1 = pricelist.tbD1.Text
pl_d2 = pricelist.tbD2.Text
pl_d3 = pricelist.tbD3.Text
pl_action = Mid(pricelist.cbHDR.value, 1, 1)
dtl_action = Mid(pricelist.cbDTL.value, 1, 1)
If Len(pricelist.cbLIST.value) > 5 Then
MsgBox ("price code must be 5 or less characters")
GoTo PRICELIST_SHOW
End If
If Not pricelist.cbInactive Then
Call x.TBLp_FilterSingle(pl, 11, "I", False)
End If
If Not pricelist.cbNonStocked Then
Call x.TBLp_FilterSingle(pl, 8, "A", True)
End If
'need to get the current list of products and if they already exist for the target price list
'target price list
'target part
'target volume level
'ulsql = FL.x.SQLp_build_sql_values(pl, True, True, PostgreSQL, False)
'pl = x.TBLp_Transpose(pl)
'plv = x.TBLp_StringToVar(pl)
'ulsql = x.json_from_table(plv, "")
'ulsql = "DECLARE GLOBAL TEMPORARY TABLE session.plb AS (" & ulsql & ") WITH DATA"
' If login.tbP.Text = "" Then
' login.Show
' If Not login.proceed Then
' Exit Sub
' End If
' End If
'Call wapi.ClipBoard_SetData(ulsql)
'Exit Sub
'If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then
' MsgBox (FL.x.ADOo_errstring)
' Exit Sub
'End If
'pl = FL.x.ADOp_SelectS(0, "SELECT p.*, CASE WHEN COALESCE(c.jcpart,'') = '' THEN '1' ELSE '2' END flag FROM Session.plb P LEFT OUTER JOIN lgdat.iprcc c ON c.jcpart = P.Item AND c.JCPLCD = '" & pl_code & "' AND c.JCVOLL = p.vbqty * cast(p.num as float) / cast(p.den as float)", True, 10000, True)
'If Not FL.x.ADOp_Exec(0, "DROP TABLE SESSION.PLB", 1, True, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then
' MsgBox (FL.x.ADOo_errstring)
' Exit Sub
'End If
'Call FL.x.ADOp_CloseCon(0)
ul(0, 0) = "HDR"
ul(1, 0) = pl_action
ul(2, 0) = pl_code
ul(3, 0) = Left(pl_d1, 30)
ul(4, 0) = Left(pl_d2, 30)
ul(5, 0) = Left(pl_d3, 30)
ul(6, 0) = "Y"
ul(7, 0) = "N"
j = 0
For i = LBound(pl, 2) + 1 To UBound(pl, 2)
'if there is no [uom, part#, price], don't create a row
If pl(11, i) <> "" And pl(7, i) <> "" And pl(6, i) <> "" And pl(13, i) <> "" Then
j = j + 1
ul(0, j) = "DTL" 'DTL
ul(1, j) = pl_code 'Price list code
ul(2, j) = pl(6, i) 'part number
ul(3, j) = pl(12, i) 'price unit
ul(4, j) = Format(pl(11, i), "0.00000") 'volume break in price uom
ul(5, j) = Format(pl(13, i), "0.00000") 'price
ul(11, j) = dtl_action 'add, update, delete
End If
Next i
ReDim Preserve ul(11, j)
'--------Open file-------------
If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then
MsgBox ("error")
End If
'Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv")
'---------------------header row---------------------------------
End Sub

49
TheBigOne.cls
View File

@ -7,6 +7,7 @@ Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private ADOo_con() As ADODB.Connection
@ -1497,11 +1498,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
@ -2137,20 +2138,20 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
needs_braces = 0
ajson = ""
For r = LBound(tbl, 1) + 1 To UBound(tbl, 1)
For c = LBound(tbl, 2) To UBound(tbl, 2)
For r = 2 To UBound(tbl, 1)
For c = 1 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(LBound(tbl, 2), c) & Chr(34) & ":" & tbl(r, c)
json = json & Chr(34) & tbl(1, 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(LBound(tbl, 2), c) & """" & ":" & tbl(r, c)
json = json & """" & tbl(1, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
@ -2158,7 +2159,7 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > LBound(tbl, 1) + 1 Then
If r > 2 Then
ajson = ajson & "," & json
Else
ajson = json
@ -2169,7 +2170,7 @@ Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As Str
'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 > LBound(tbl, 1) + 2 Then
If r > 3 Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
@ -2544,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 BaseSize As Integer
BaseSize = Len(sNewBaseDigits)
Do While Val(d) <> 0
Do While val(d) <> 0
tmp = d
i = 0
Do While tmp >= BaseSize
@ -2669,8 +2670,8 @@ Function TBLp_Transpose(ByRef t() As String) As String()
ReDim x(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
For i = LBound(t, 2) To UBound(t, 2)
For j = LBound(t, 1) To UBound(t, 1)
For i = 1 To UBound(t, 2)
For j = 1 To UBound(t, 1)
x(i, j) = t(j, i)
Next j
Next i
@ -2699,28 +2700,7 @@ Function TBLp_VarToString(ByRef t() As Variant) As String()
End Function
Function TBLp_StringToVar(ByRef t() As String) As Variant()
Dim i As Long
Dim j As Long
Dim x() As Variant
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2))
For i = LBound(t, 1) To UBound(t, 1)
For j = LBound(t, 2) To UBound(t, 2)
x(i, j) = t(i, j)
Next j
Next i
TBLp_StringToVar = x
End Function
Sub frmListBoxHeader(ByRef hdr As MSForms.ListBox, ByRef det As MSForms.ListBox, ParamArray cols())
Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
Dim i As Long
@ -2748,4 +2728,3 @@ Sub frmListBoxHeader(ByRef hdr As MSForms.ListBox, ByRef det As MSForms.ListBox,
End Sub