Attribute VB_Name = "PriceLists" Option Explicit Public tbo As New TheBigOne 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) login.Caption = "PostgreSQL Login" login.tbU = "report" login.tbP = "report" login.Show If Not login.proceed Then Exit Sub 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 '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 '---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 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 '---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----------- load = unpivot_current_sheet(plist, pcol) '-------filter out any -0- prices before loading Call x.TBLp_FilterSingle(load, 8, "0.00", False) '------if no columns are labeled plist then exit------------------------------ If UBound(pcol) = 0 Then Exit Sub '------clear out overlapping price lists-------------------------------------- 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 If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "Port=5432;Database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If '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------------- 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 Sub build_customer_files() 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 clist() As String Dim plev As String Dim effdate As Date Dim segment_regex As String Dim curr As String Dim fname As String '----------------------pick price level--------------------------------------------------------------------- login.Caption = "PostgreSQL Login" login.tbU = "report" login.tbP = "report" login.proceed = True 'login.Show If Not login.proceed Then Exit Sub 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 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 effdate = CDate(pricelevel.tbEddDate.text) filepath = pricelevel.tbPATH & "\" & plev 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 End If 'Application.ScreenUpdating = True 'Exit Sub '---------------------create new workbook------------------------------------------------------------------- Set nwb = Application.Workbooks.Add nwb.Activate Set nws = nwb.Sheets(1) segment_regex = "^G|^N|^F|^P" '---------------------get price list------------------------------------------------------------------------ If pricelevel.chbNURSERY Then pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") 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" Set nnws = nwb.Sheets.Add(, nws) nnws.Name = "Price List - Nursery" Call paste_pretty(pln, nnws, effdate, curr) End If End If If pricelevel.chbFIBER Then plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") 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" Else segment_regex = "^G|^N|^P" End If Set nfws = nwb.Sheets.Add(, nws) nfws.Name = "Price List - Fiber" Call paste_pretty(plf, nfws, effdate, curr) End If End If pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", 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 If UBound(pl, 2) > 21 Then nws.Name = "Price list" Call paste_pretty(pl, nws, effdate, curr) Else nws.Delete End If 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 fname = "HC Companies Distributor Price List " & curr & ".xlsx" Dim wb As Workbook For Each wb In Workbooks If wb.Name = fname Then If MsgBox("already have a price list open, close it?", vbOKCancel) Then Workbooks(fname).Close Exit For Else Exit Sub End If End If Next wb If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname 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 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.xlsx" If Not pricelevel.chbLEAVEOPEN Then fcwb.Close End If End If End Sub Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date, ByRef curr As String) 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 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 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 Application.ScreenUpdating = False '---------------------whole sheet formatting---------------------------------------------------------------- nws.Columns(9).HorizontalAlignment = xlRight nws.Columns(10).HorizontalAlignment = xlRight nws.Columns(11).HorizontalAlignment = xlRight nws.Columns(12).HorizontalAlignment = xlRight nws.Columns(13).HorizontalAlignment = xlRight nws.Columns(14).HorizontalAlignment = xlRight nws.Columns(15).HorizontalAlignment = xlRight nws.Columns(16).HorizontalAlignment = xlRight nws.Columns(17).HorizontalAlignment = xlRight 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 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 nws.Columns(11).ColumnWidth = 11.71 nws.Columns(14).ColumnWidth = 11.71 nws.Columns(17).ColumnWidth = 13 ActiveWindow.DisplayGridlines = False 'nws.Cells.Font.Name = "Cascadia Code Light" nws.Cells.Font.Name = "Courier New" nws.Cells.Font.Size = 10 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 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 With nws.Range("I4") .value = "------Single Package------" .HorizontalAlignment = xlLeft .InsertIndent 1 .WrapText = False End With With nws.Range("L4") .value = "--------Full Pallet-------" .HorizontalAlignment = xlLeft .InsertIndent 1 .WrapText = False End With With nws.Range("O4") .value = "--------Bulk Pallet-------" .HorizontalAlignment = xlLeft .InsertIndent 1 .WrapText = False 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 '--------------------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) '--------------------indent compatible--------------- If nws.Cells(i, 18) = "compatible" Then Call compatible(nws, i, 1, 2) '--------------------highlight price--------------- If nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible" Then Call price_col(nws, i, 20) '--------------------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) = "'" '-------------------apply border------------------ If pricelevel.chbBorders And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then Call border(nws, i, lastcol) '--------------------merge products--------------- If nws.Cells(i, 1) = nws.Cells(i - 1, 1) And nws.Cells(i, 1) <> nws.Cells(i + 1, 1) Then '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 '-------------------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 '--------------------print header data-------------------------------------------------------------------------- pl = tbo.TBLp_Transpose(pl) Call tbo.TBLp_FilterSingle(pl, 20, "", False) Call tbo.TBLp_Group(pl, True, tbo.ARRAYp_MakeInteger(20)) 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") nws.Cells(5, 1).Select Call print_setup(nws, last) nws.Columns("R:V").Delete 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 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 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) 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 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 Sub print_setup(sheet As Worksheet, last_row As Long) Dim Sel As Range Dim i As Long Dim j As Long Set Sel = rrange(sheet, 6, last_row, 1, 17) Application.PrintCommunication = False 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) .Orientation = xlLandscape .FitToPagesWide = 1 End With sheet.PageSetup.FitToPagesWide = 1 sheet.PageSetup.FitToPagesTall = 0 '-------------------force a page break on color codes---------- j = 1 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 sheet.DisplayPageBreaks = False Application.PrintCommunication = True sheet.DisplayPageBreaks = False End Sub 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