VBA/PriceLists.bas

1195 lines
42 KiB
QBasic
Raw Normal View History

Attribute VB_Name = "PriceLists"
Option Explicit
Public tbo As New TheBigOne
2022-04-07 12:39:00 -04:00
Sub test_full20()
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl() As Variant
Dim lists() As String
Dim pcol() As Long
Dim unp() As String
Dim unv() As Variant
Dim onelist() As String
Dim i As Long
Dim l As Long
Dim j As Long
Dim unps() As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim ini As Range
Dim cms_pl() As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
Set ini = Application.Selection
Selection.CurrentRegion.Select
Set orig = Application.Selection
unp = unpivot_current_sheet(lists, pcol)
2022-05-20 13:12:21 -04:00
login.Caption = "PostgreSQL Login"
login.tbU = "report"
login.tbP = "report"
login.Show
If Not login.proceed Then Exit Sub
2023-04-27 07:36:19 -04:00
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") Then
MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
Exit Sub
End If
Application.ScreenUpdating = False
With orig.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For l = 1 To UBound(lists)
'----------filter the main data set for each price lists (due to json_from_table taking forever on big tables)--------
onelist = unp
Call x.TBLp_FilterSingle(onelist, 9, lists(l), True)
onelist = x.TBLp_Transpose(onelist)
unv = x.TBLp_StringToVar(onelist)
'-------------------------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.plcore_fullcode_inq($$" & sql & "$$::jsonb)"
Call wapi.ClipBoard_SetData(sql)
'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
'Exit Sub
cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True)
'--------------------------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.Activate
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
'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), orig.column + cms_pl(i, 14)).Interior.ThemeColor = xlThemeColorAccent6
Case "No UOM Conversion"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 255, 161)
End If
Case "Inactive"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 20, 161)
End If
Case "No SKU"
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(20, 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
Next l
Call x.ADOp_CloseCon(0)
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
2022-04-07 12:39:00 -04:00
'flag any cells that have prices that are not a formula
If IsNumeric(cell.value) And Mid(cell.Formula, 1, 1) <> "=" And cell.row > 3 And cell.column > 6 Then
'cell.Interior.Color = RGB(186, 85, 211)
' With cell.Borders(xlEdgeLeft)
' .LineStyle = xlContinuous
' .Color = -6279056
' .TintAndShade = 0
' .Weight = xlThick
' End With
' With cell.Borders(xlEdgeTop)
' .LineStyle = xlContinuous
' .Color = -6279056
' .TintAndShade = 0
' .Weight = xlThick
' End With
' With cell.Borders(xlEdgeRight)
' .LineStyle = xlContinuous
' .Color = -6279056
' .TintAndShade = 0
' .Weight = xlThick
' End With
' With cell.Borders(xlEdgeBottom)
' .LineStyle = xlContinuous
' .Color = -6279056
' .TintAndShade = 0
' .Weight = xlThick
' End With
End If
cell.Interior.Pattern = xlNone
Else
If cell.Interior.Pattern = xlNone And cell.value <> "" Then
2022-04-07 12:39:00 -04:00
'---yellow-------
cell.Interior.Color = RGB(255, 255, 161)
End If
End If
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
For i = 1 To UBound(pcol)
Selection.Columns(pcol(i) + 1).Interior.Pattern = xlNone
Next i
Application.ScreenUpdating = True
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
ini.Select
End Sub
Sub price_load_plcore()
Dim x As New TheBigOne 'function library
Dim load() As String 'individual price list to be loaded
Dim pcol() As Long 'hold the positions of each price list
2022-04-07 12:39:00 -04:00
Dim plist() As String
Dim i As Long 'walks through each price list
Dim j As Long 'walks through each original row
Dim k As Long 'creates new rows for each price break
Dim m As Long 'row position in the new table
Dim sql As String
2022-04-07 12:39:00 -04:00
'---current setup takes 2 minutes. need to break into smaller uploads, one price list per round--
'-------identify the active sheet and load the contents to an array-----------
2022-04-07 12:39:00 -04:00
load = unpivot_current_sheet(plist, pcol)
'-------filter out any -0- prices before loading
Call x.TBLp_FilterSingle(load, 8, "0.00", False)
2022-04-07 12:39:00 -04:00
'------if no columns are labeled plist then exit------------------------------
2022-04-07 12:39:00 -04:00
If UBound(pcol) = 0 Then Exit Sub
2022-04-07 12:39:00 -04:00
'------clear out overlapping price lists--------------------------------------
2022-04-07 12:39:00 -04:00
sql = ""
For i = 1 To UBound(plist)
If i > 1 Then
sql = sql & ",'" & plist(i) & "'"
Else
sql = sql & "'" & plist(i) & "'"
End If
Next i
sql = "DELETE FROM rlarp.plcore WHERE listcode in (" & sql & ");"
sql = sql & vbCrLf & "INSERT INTO rlarp.plcore"
sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S", "N", "N") & ";"
login.Caption = "Postgres Login"
login.tbU = LCase(Mid(Application.UserLibraryPath, 10, InStr(10, Application.UserLibraryPath, "\") - 10))
login.Show
If Not login.proceed Then Exit Sub
2023-04-27 07:36:19 -04:00
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "Port=5432;Database=ubm") Then
2022-04-07 12:39:00 -04:00
MsgBox (x.ADOo_errstring)
Exit Sub
End If
2022-05-17 10:33:24 -04:00
'If Not x.ADOp_Exec(1, sql, 1, True, ADOinterface.SqlServer, "mid-sql02", True) Then
' MsgBox (x.ADOo_errstring)
' Exit Sub
'End If
End Sub
Sub build_csv()
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
'--------------remove any lines with errors-------------
If Not pricelist.cbInactive Then
Call x.TBLp_FilterSingle(pl, 16, "", True)
End If
'--------------remove empty price lines-----------------
Call x.TBLp_FilterSingle(pl, 13, "", False)
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
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-------------
2022-05-27 00:26:36 -04:00
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
Function unpivot_current_sheet(ByRef lists() As String, ByRef pcol() As Long) As String()
Dim x As New TheBigOne 'function library
Dim sh As Worksheet 'target worksheet
Dim big() As String 'all price lists in one array
Dim unpivot() As String 'unwrap the columns into volume level rows
Dim load() As String 'individual price list to be loaded
Dim pcount As Long 'count of price list
'Dim pcol() As Long 'hold the positions of each price list
ReDim pcol(30) 'size the array starting with 30 and trim later
ReDim lists(30)
Dim dcol() As Integer 'columns to be deleted
Dim typeflag() As String 'array of column types
Dim i As Long 'walks through each price list
Dim j As Long 'walks through each original row
Dim k As Long 'creates new rows for each price break
Dim m As Long 'row position in the new table
Dim sql As String
'-------identify the active sheet and load the contents to an array-----------
Set sh = ActiveSheet
big = x.SHTp_Get(sh.Name, 3, 1, True)
'------iterate through the column headers to identify the price lists---------
pcount = 0
For i = 0 To UBound(big, 1)
If big(i, 0) = "plist" Then
pcount = pcount + 1
pcol(pcount) = i
lists(pcount) = big(i, 1)
End If
Next i
'------if no columns are labeled plist then exit------------------------------
If pcount = 0 Then Exit Function
ReDim Preserve pcol(pcount)
ReDim Preserve lists(pcount)
ReDim typeflag(9)
'----since there are 3 price columns, those will need transformed to 3 price rows per each original-----
ReDim load(11, UBound(big, 2) * 3 * pcount)
m = 1
'----set headers-----
load(0, 0) = "stlc"
load(1, 0) = "coltier"
load(2, 0) = "branding"
load(3, 0) = "accs"
load(4, 0) = "suffix"
load(5, 0) = "uomp"
load(6, 0) = "vol_uom"
load(7, 0) = "vol_qty"
load(8, 0) = "vol_price"
load(9, 0) = "listcode"
load(10, 0) = "orig_row"
load(11, 0) = "orig_col"
For pcount = 1 To UBound(pcol)
'-----populate------------
For i = 1 To UBound(big, 2)
'-----hard coded to number of price breaks (3)-------
For k = 0 To 2
load(0, m) = big(0, i)
load(1, m) = big(1, i)
load(2, m) = big(2, i)
load(3, m) = big(3, i)
load(4, m) = big(4, i)
'----position 3 is a bulk pallet so the default UOM needs hard coded to PLT-----
If k = 2 Then
load(5, m) = "PLT"
Else
load(5, m) = big(5, i)
End If
'----(3-k) should work out to 1st 2nd 3rd price colum----------------------------
'----the first column UOM is the default package, everything else is a pallet----
If k = 0 Then
load(6, m) = big(5, i)
Else
load(6, m) = "PLT"
End If
'----for now the volumes are always 1 of the unit of measure in colunm 6 above
load(7, m) = "1"
load(8, m) = Format(big(pcol(pcount) - (3 - k), i), "####0.00")
load(9, m) = big(pcol(pcount) - 0, i)
load(10, m) = i
load(11, m) = pcol(pcount) - (3 - k)
m = m + 1
Next k
Next i
Next pcount
If Not x.TBLp_TestNumeric(load, 8) Then
MsgBox ("price is text")
Exit Function
End If
unpivot_current_sheet = load
End Function
2022-05-18 12:58:40 -04:00
Sub build_customer_files()
Dim x As New TheBigOne
2023-04-27 07:36:19 -04:00
Dim i As Long
Dim pl() As String
2022-06-09 15:11:52 -04:00
Dim pln() As String
Dim plf() As String
2022-05-18 12:58:40 -04:00
Dim fc() As String
Dim nwb As Workbook
2022-05-18 12:58:40 -04:00
Dim fcwb As Workbook
Dim nws As Worksheet
2022-06-09 15:11:52 -04:00
Dim nnws As Worksheet
Dim nfws As Worksheet
2022-05-18 12:58:40 -04:00
Dim fcws As Worksheet
2022-05-12 17:39:53 -04:00
Dim filepath As String
Dim clist() As String
Dim plev As String
Dim effdate As Date
2022-06-09 15:11:52 -04:00
Dim segment_regex As String
Dim curr As String
Dim fname As String
2022-05-17 10:33:24 -04:00
'----------------------pick price level---------------------------------------------------------------------
2022-05-20 13:12:21 -04:00
login.Caption = "PostgreSQL Login"
2022-05-18 12:58:40 -04:00
login.tbU = "report"
login.tbP = "report"
2023-04-27 07:36:19 -04:00
login.proceed = True
'login.Show
If Not login.proceed Then Exit Sub
2022-05-17 10:33:24 -04:00
Call pricelevel.repopulate
pricelevel.Show
If pricelevel.cancel Then Exit Sub
If Not IsDate(pricelevel.tbEddDate.text) Then
MsgBox ("cannot interperet date - " & pricelevel.tbEddDate.text)
Exit Sub
End If
2023-04-27 07:36:19 -04:00
For i = 0 To pricelevel.lbPriceLev.ListCount - 1
If pricelevel.lbPriceLev.Selected(i) Then
plev = pricelevel.lbPriceLev.list(i)
Call build_price_level(plev)
End If
Next i
End Sub
Sub build_price_level(plev As String)
Dim x As New TheBigOne
Dim i As Long
Dim pl() As String
Dim pln() As String
Dim plf() As String
Dim fc() As String
Dim nwb As Workbook
Dim fcwb As Workbook
Dim nws As Worksheet
Dim nnws As Worksheet
Dim nfws As Worksheet
Dim fcws As Worksheet
Dim filepath As String
Dim effdate As Date
Dim clist() As String
Dim segment_regex As String
Dim curr As String
Dim fname As String
2022-05-17 10:33:24 -04:00
effdate = CDate(pricelevel.tbEddDate.text)
2022-05-27 00:26:36 -04:00
filepath = pricelevel.tbPATH & "\" & plev
2022-05-18 12:58:40 -04:00
2022-06-09 15:11:52 -04:00
'---------------------create new workbook-------------------------------------------------------------------
Set nwb = Application.Workbooks.Add
nwb.Activate
Set nws = nwb.Sheets(1)
segment_regex = "^G|^N|^F|^P"
2022-06-09 15:11:52 -04:00
2022-05-17 10:33:24 -04:00
'---------------------get price list------------------------------------------------------------------------
2022-06-09 15:11:52 -04:00
If pricelevel.chbNURSERY Then
2023-05-22 11:41:09 -04:00
pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
2022-06-09 15:11:52 -04:00
If pln(0, 0) <> "Product" Then
MsgBox (pln(0, 0))
Exit Sub
End If
If UBound(pln, 2) > 21 Then
segment_regex = "^F|^G|^P"
2022-06-09 15:11:52 -04:00
Set nnws = nwb.Sheets.Add(, nws)
nnws.Name = "Price List - Nursery"
Call paste_pretty(pln, nnws, effdate, curr)
2022-06-09 15:11:52 -04:00
End If
End If
If pricelevel.chbFIBER Then
2023-05-22 11:41:09 -04:00
plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
2022-06-09 15:11:52 -04:00
If plf(0, 0) <> "Product" Then
MsgBox (plf(0, 0))
Exit Sub
End If
If UBound(plf, 2) > 21 Then
If segment_regex = "^F|^G|^P" Then
segment_regex = "^G|^P"
2022-06-09 15:11:52 -04:00
Else
segment_regex = "^G|^N|^P"
2022-06-09 15:11:52 -04:00
End If
Set nfws = nwb.Sheets.Add(, nws)
nfws.Name = "Price List - Fiber"
Call paste_pretty(plf, nfws, effdate, curr)
2022-06-09 15:11:52 -04:00
End If
End If
2023-05-22 11:41:09 -04:00
pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "usmidsap01", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If pl(0, 0) <> "Product" Then
MsgBox (pl(0, 0))
Exit Sub
End If
2022-06-09 15:11:52 -04:00
If UBound(pl, 2) > 21 Then
nws.Name = "Price list"
Call paste_pretty(pl, nws, effdate, curr)
2022-06-09 15:11:52 -04:00
Else
'---if the price list has no length, then close the worksheet.
'---if it's the last worksheet, then close the whole workbook
If nwb.Sheets.Count = 1 Then
Call nwb.Close(False)
Exit Sub
Else
nws.Delete
End If
2022-06-09 15:11:52 -04:00
End If
2022-06-09 15:11:52 -04:00
Application.ScreenUpdating = True
'--------------------save file--------------------------------------------------------------------------------
'Dim fd As Object
'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'fd.Show
'If fd.SelectedItems.Count = 0 Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(filepath) Then .CreateFolder filepath
End With
Application.DisplayAlerts = True
nwb.Activate
2022-06-09 15:11:52 -04:00
fname = "HC Companies Distributor Price List " & curr & ".xlsx"
2022-06-09 15:11:52 -04:00
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = fname Then
2022-06-09 15:11:52 -04:00
If MsgBox("already have a price list open, close it?", vbOKCancel) Then
Workbooks(fname).Close
2022-06-09 15:11:52 -04:00
Exit For
Else
Exit Sub
End If
End If
Next wb
If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname
2022-06-09 15:11:52 -04:00
2022-08-04 16:47:57 -04:00
If pricelevel.chPDF Then
fname = Replace(fname, "xlsx", "pdf")
nwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
If Not pricelevel.chbLEAVEOPEN Then
nwb.Close
End If
'--------------------get full code list-----------------------------
If pricelevel.chbFULLCODE Then
'---------------------get full code list--------------------------------------------------------------------
fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
If fc(0, 0) <> "Currency" Then
MsgBox (fc(0, 0))
Exit Sub
End If
'---------------------create new workbook-------------------------------------------------------------------
If UBound(fc, 2) = 0 Then
'MsgBox ("no full code list data for " & plev)
Exit Sub
End If
Application.ScreenUpdating = False
Set fcwb = Application.Workbooks.Add
fcwb.Activate
Set fcws = fcwb.Sheets(1)
fcws.Activate
'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric
Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14)
Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'--------------------format full code------------------------------------------------------------------------
Application.CutCopyMode = False
fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing"
fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21"
fcws.Cells.Font.Name = "Courier New"
fcws.Cells.Font.Size = 10
With fcws.Rows(3)
.WrapText = True
.RowHeight = 40.5
End With
fcws.Columns("A").ColumnWidth = 9.43
fcws.Columns("B").ColumnWidth = 20
fcws.Columns("C:D").ColumnWidth = 35
fcws.Columns("E").ColumnWidth = 21.5
fcws.Columns("F").ColumnWidth = 3.71
fcws.Columns("G").ColumnWidth = 9.43
fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
fcws.Columns("H").ColumnWidth = 7.14
fcws.Columns("I:P").ColumnWidth = 14
fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
fcws.Columns("O").ColumnWidth = 10.57
fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
Rows("3:3").NumberFormat = "General"
fcws.Activate
ActiveWindow.DisplayGridlines = False
Rows("4:4").Select
ActiveWindow.FreezePanes = True
fcws.ListObjects("Full Code Listing").ShowAutoFilter = False
'---------------------logo----------------------------------------------------------------------------------
fcws.Rows("1:2").RowHeight = 28.5
fcws.Cells(1, 1).Select
ActiveSheet.Pictures.Insert("https://hccompanies.sharepoint.com/_layouts/15/download.aspx?UniqueId=2ee21088%2Ddad1%2D41aa%2Daf65%2D14b44c46941e").Select
'Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.375, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.IncrementLeft 2
'Selection.ShapeRange.IncrementTop 2
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
ActiveSheet.Cells(5, 1).Select
fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY")
fcws.Name = "Full Code Listing"
fcws.Cells(3, 1).Select
'------------formatting for print-----------------------------------
Application.PrintCommunication = False
fcws.PageSetup.PrintTitleRows = "$1:$3"
fcws.PageSetup.Orientation = xlLandscape
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
End If
'---------------------save full code list---------------------------
2022-06-09 15:11:52 -04:00
For Each wb In Workbooks
If wb.Name = "HC FullCode List.xlsx" Then
If MsgBox("already have a full code list open, close it?", vbOKCancel) Then
Workbooks("HC FullCode List.xlsx").Close
Exit For
Else
Exit Sub
End If
End If
Next wb
If Not (fcwb Is Nothing) Then
If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List " & curr & ".xlsx"
2023-05-22 11:41:09 -04:00
If pricelevel.chPDF Then
fname = Replace(fcwb.Name, "xlsx", "pdf")
fcwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
2022-08-04 16:47:57 -04:00
If Not pricelevel.chbLEAVEOPEN Then
fcwb.Close
End If
2022-06-09 15:11:52 -04:00
End If
End Sub
Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date, ByRef curr As String)
2022-06-09 15:11:52 -04:00
Dim c As Range
Dim i As Long
Dim last As Long
Dim lastcol As Long
Dim j As Long
nws.Activate
nws.Cells.NumberFormat = "@"
'---------------------format to numeric if selected---------------------------------------------------------
If pricelevel.cbNUMERIC Then
2022-06-09 15:11:52 -04:00
Call tbo.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16)
nws.Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
nws.Columns(10).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(13).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(16).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(11).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(14).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(17).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
nws.Columns(10).ColumnWidth = 13
nws.Columns(13).ColumnWidth = 13
nws.Columns(16).ColumnWidth = 13
nws.Rows(5).NumberFormat = "@"
Else
2022-06-09 15:11:52 -04:00
Call tbo.SHTp_Dump(pl, nws.Name, 5, 1, False, True)
nws.Columns(10).ColumnWidth = 10.57
nws.Columns(13).ColumnWidth = 10.57
nws.Columns(16).ColumnWidth = 10.57
End If
2022-05-12 12:38:56 -04:00
Application.ScreenUpdating = False
'---------------------whole sheet formatting----------------------------------------------------------------
2022-05-27 00:26:36 -04:00
nws.Columns(9).HorizontalAlignment = xlRight
nws.Columns(10).HorizontalAlignment = xlRight
nws.Columns(11).HorizontalAlignment = xlRight
2022-05-27 00:26:36 -04:00
nws.Columns(12).HorizontalAlignment = xlRight
nws.Columns(13).HorizontalAlignment = xlRight
nws.Columns(14).HorizontalAlignment = xlRight
2022-05-27 00:26:36 -04:00
nws.Columns(15).HorizontalAlignment = xlRight
nws.Columns(16).HorizontalAlignment = xlRight
nws.Columns(17).HorizontalAlignment = xlRight
2022-05-12 12:38:56 -04:00
nws.Columns(1).ColumnWidth = 12
nws.Columns(2).ColumnWidth = 70
nws.Columns(3).ColumnWidth = 8.29
nws.Columns(4).ColumnWidth = 4.86
nws.Columns(5).ColumnWidth = 4.86
nws.Columns(6).ColumnWidth = 4.86
nws.Columns(7).ColumnWidth = 4.86
2022-05-27 00:26:36 -04:00
If pricelevel.chbColors Then
nws.Columns(8).ColumnWidth = 17
nws.Columns(8).WrapText = True
Else
nws.Columns(8).ColumnWidth = 11
End If
nws.Columns(9).ColumnWidth = 8.29
nws.Columns(9).WrapText = True
nws.Columns(12).ColumnWidth = 8.29
nws.Columns(12).WrapText = True
nws.Columns(15).ColumnWidth = 8.29
nws.Columns(15).WrapText = True
2022-05-12 12:38:56 -04:00
nws.Columns(11).ColumnWidth = 11.71
nws.Columns(14).ColumnWidth = 11.71
nws.Columns(17).ColumnWidth = 13
ActiveWindow.DisplayGridlines = False
2022-05-18 12:58:40 -04:00
'nws.Cells.Font.Name = "Cascadia Code Light"
nws.Cells.Font.Name = "Courier New"
nws.Cells.Font.Size = 10
2022-05-12 12:38:56 -04:00
Rows("6:6").Select
ActiveWindow.FreezePanes = True
'---------------------logo----------------------------------------------------------------------------------
ActiveSheet.Cells(1, 1).Select
ActiveSheet.Pictures.Insert("https://hccompanies.sharepoint.com/_layouts/15/download.aspx?UniqueId=2ee21088%2Ddad1%2D41aa%2Daf65%2D14b44c46941e").Select
'Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.375, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.IncrementLeft 2
'Selection.ShapeRange.IncrementTop 2
2022-05-12 12:38:56 -04:00
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
ActiveSheet.Cells(5, 1).Select
'---------------------header formatting---------------------------------------------------------------------
For Each c In Range("I5:Q5").Cells
c.value = Left(c.value, Len(c.value) - 1)
Next c
Application.DisplayAlerts = False
2022-05-12 12:38:56 -04:00
With nws.Range("I4")
2022-05-27 00:26:36 -04:00
.value = "------Single Package------"
2022-05-12 12:38:56 -04:00
.HorizontalAlignment = xlLeft
2022-05-27 00:26:36 -04:00
.InsertIndent 1
.WrapText = False
2022-05-12 12:38:56 -04:00
End With
With nws.Range("L4")
2022-05-27 00:26:36 -04:00
.value = "--------Full Pallet-------"
2022-05-12 12:38:56 -04:00
.HorizontalAlignment = xlLeft
2022-05-27 00:26:36 -04:00
.InsertIndent 1
.WrapText = False
2022-05-12 12:38:56 -04:00
End With
With nws.Range("O4")
2022-05-27 00:26:36 -04:00
.value = "--------Bulk Pallet-------"
2022-05-12 12:38:56 -04:00
.HorizontalAlignment = xlLeft
2022-05-27 00:26:36 -04:00
.InsertIndent 1
.WrapText = False
2022-05-12 12:38:56 -04:00
End With
Application.DisplayAlerts = True
'---------------------find size of table---------------------------------------------------------------------
i = 6
Do Until nws.Cells(i, 18) = ""
i = i + 1
Loop
last = i - 1
lastcol = 17
'--------------------line formatting--------------------------------------------------------------------------
For i = 6 To last
2022-05-12 12:38:56 -04:00
'--------------------format header---------------
If nws.Cells(i, 18) = "header" Then Call header(nws, i, 1, lastcol)
'--------------------create bands---------------
If nws.Cells(i, 20) = "1" And Not nws.Cells(i, 18) = "header" Then Call banding(nws, i, 1, lastcol)
2022-05-12 12:38:56 -04:00
'--------------------indent compatible---------------
If nws.Cells(i, 18) = "compatible" Then Call compatible(nws, i, 1, 2)
2022-05-12 12:38:56 -04:00
'--------------------highlight price---------------
If nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible" Then Call price_col(nws, i, 20)
2022-05-12 12:38:56 -04:00
'--------------------comment empy qty to prevent colors from spilling
If nws.Cells(i, 9) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 9) = "'"
If nws.Cells(i, 11) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 11) = "'"
If nws.Cells(i, 12) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 12) = "'"
If nws.Cells(i, 14) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 14) = "'"
If nws.Cells(i, 15) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 15) = "'"
2022-05-27 00:26:36 -04:00
'-------------------apply border------------------
If pricelevel.chbBorders And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then Call border(nws, i, lastcol)
2022-05-12 12:38:56 -04:00
'--------------------merge products---------------
If nws.Cells(i, 1) = nws.Cells(i - 1, 1) And nws.Cells(i, 1) <> nws.Cells(i + 1, 1) Then
2022-05-12 12:38:56 -04:00
'if the next row is different and the previous row is the same the loop back and merge the range
j = -1
Do Until nws.Cells(i + j, 1) <> nws.Cells(i, 1)
j = j - 1
Loop
j = j + 1
If j < 0 Then Call merge(nws, i + j, i)
End If
2022-05-27 00:26:36 -04:00
'-------------------auto fit row for wrapped colors-------
nws.Rows(i).EntireRow.autofit
'-------------------reformat line breaks----------
'nws.Cells(i, 9) = split_and_rebuild(nws.Cells(i, 9))
'nws.Cells(i, 12) = split_and_rebuild(nws.Cells(i, 12))
'nws.Cells(i, 15) = split_and_rebuild(nws.Cells(i, 15))
Next i
2022-05-19 11:46:05 -04:00
'--------------------print header data--------------------------------------------------------------------------
2022-06-09 15:11:52 -04:00
pl = tbo.TBLp_Transpose(pl)
Call tbo.TBLp_FilterSingle(pl, 20, "", False)
Call tbo.TBLp_Group(pl, True, tbo.ARRAYp_MakeInteger(20))
2022-05-12 17:39:53 -04:00
If UBound(pl, 2) > 1 Then
'---somehow multiple currencies involved----
MsgBox ("multiple currencies")
Exit Sub
Else
Select Case pl(20, 1)
Case "C"
curr = "CAD"
Case "U"
curr = "USD"
Case Else
MsgBox ("unknown currency - " & pl(20, 1))
End Select
End If
nws.Cells(2, 3).value = "Distributor Price List (" & curr & ") - Effective " & Format(effdate, "MM/DD/YYYY")
2022-05-12 12:38:56 -04:00
nws.Cells(5, 1).Select
Call print_setup(nws, last)
2022-05-12 12:38:56 -04:00
nws.Columns("R:V").Delete
2022-06-09 15:11:52 -04:00
End Sub
Function rrange(ByRef sheet As Worksheet, start_row As Long, end_row As Long, start_col As Long, end_col As Long) As Range
Set rrange = Range(sheet.Cells(start_row, start_col).address & ":" & sheet.Cells(end_row, end_col).address)
End Function
2022-05-12 12:38:56 -04:00
Sub price_col(ByRef sheet As Worksheet, row As Long, flag_col As Long)
Dim Sel As Range
Dim i As Long
i = 0
Do Until i = 9
Set Sel = rrange(sheet, row, row, 10 + i, 10 + i)
If sheet.Cells(row, flag_col) = "0" Then
With Sel.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Else
With Sel.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
End If
i = i + 3
Loop
End Sub
Sub merge(ByRef ws As Worksheet, start_row As Long, end_row As Long)
Dim Sel As Range
Dim i As Long
Application.DisplayAlerts = False
For i = 1 To 2
Set Sel = rrange(ws, start_row, end_row, i, i)
With Sel
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
Application.DisplayAlerts = True
End Sub
Sub compatible(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)
Dim Sel As Range
Set Sel = rrange(ws, row, row, start_col, end_col)
Sel.InsertIndent 2
End Sub
Sub banding(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)
Dim Sel As Range
Set Sel = rrange(ws, row, row, start_col, end_col)
With Sel.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Sub
2022-05-12 12:38:56 -04:00
Sub header(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)
Dim Sel As Range
Set Sel = rrange(ws, row, row, start_col, end_col)
2022-05-12 12:38:56 -04:00
Sel.InsertIndent 2
Sel.Font.Size = 11
With Sel.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Sel.Borders(xlDiagonalDown).LineStyle = xlNone
Sel.Borders(xlDiagonalUp).LineStyle = xlNone
With Sel.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThick
End With
With Sel.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThick
End With
With Sel.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThick
End With
With Sel.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThick
End With
Sel.Borders(xlInsideVertical).LineStyle = xlNone
Sel.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
2022-05-27 00:26:36 -04:00
Sub border(ByRef ws As Worksheet, row As Long, lastcol As Long)
Dim target As Range
Set target = ws.Range(ws.Cells(row, 1), ws.Cells(row, lastcol))
If ws.Cells(row - 1, 18) <> "header" Then
With target.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
End If
With target.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With target.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
End Sub
Function split_and_rebuild(text As String) As String
Dim i As Long
Dim last As Long
Dim newt As String
newt = ""
i = 1
last = 1
Do Until InStr(i, text, Chr(10)) = 0
i = InStr(i, text, Chr(10))
newt = newt & Mid(text, last, i - 1) & Chr(10)
last = i
i = i + 1
Loop
newt = newt & Mid(text, i, 100)
split_and_rebuild = newt
End Function
2022-05-12 12:38:56 -04:00
Sub print_setup(sheet As Worksheet, last_row As Long)
2022-05-12 12:38:56 -04:00
Dim Sel As Range
Dim i As Long
Dim j As Long
2022-05-12 12:38:56 -04:00
Set Sel = rrange(sheet, 6, last_row, 1, 17)
2022-05-17 10:33:24 -04:00
Application.PrintCommunication = False
2022-05-12 12:38:56 -04:00
With sheet.PageSetup
.PrintArea = Sel.address
.PrintTitleRows = "$1:$5"
'.FitToPagesTall = 0
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
2022-05-17 10:33:24 -04:00
.Orientation = xlLandscape
.FitToPagesWide = 1
2022-05-12 12:38:56 -04:00
End With
2022-05-17 10:33:24 -04:00
sheet.PageSetup.FitToPagesWide = 1
sheet.PageSetup.FitToPagesTall = 0
'-------------------force a page break on color codes----------
j = 1
2022-05-27 00:26:36 -04:00
For i = 5 To last_row
If j >= 810 Then
sheet.HPageBreaks.Add before:=sheet.Rows(i + 1)
j = 1
End If
'every 73 rows is a page break for current font, but if a row is taller this needs accounted for
If sheet.Cells(i, 18) = "colors" And sheet.Cells(i - 1, 18) <> "colors" Then
sheet.HPageBreaks.Add before:=sheet.Rows(i)
j = 1
End If
If sheet.Cells(i, 18) = "notes" And sheet.Cells(i - 1, 18) <> "notes" Then
sheet.HPageBreaks.Add before:=sheet.Rows(i)
j = 1
End If
j = j + sheet.Rows(i).RowHeight
Next i
2022-05-12 17:39:53 -04:00
sheet.DisplayPageBreaks = False
2022-05-17 10:33:24 -04:00
Application.PrintCommunication = True
2022-05-27 00:26:36 -04:00
sheet.DisplayPageBreaks = False
2022-05-12 12:38:56 -04:00
End Sub
2022-05-27 00:26:36 -04:00
Public Function plevel_segment(plevel As String, segment_num As Integer) As String
Dim ret() As String
ret = tbo.TXTp_ParseCSV(plevel, ".")
If segment_num - 1 > UBound(ret) Then
plevel_segment = ""
Else
plevel_segment = ret(segment_num - 1)
End If
End Function