Attribute VB_Name = "PriceLists" Option Explicit 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 = "Postgres Login" login.tbU = "report" login.tbP = "report" 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 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, "usmidlnx01", False, login.tbU, login.tbP, "Port=5030;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 pl() As String Dim fc() As String Dim nwb As Workbook Dim fcwb As Workbook Dim nws As Worksheet Dim fcws As Worksheet Dim filepath As String Dim c As Range Dim i As Long Dim j As Long Dim last As Long Dim lastcol As Long Dim clist() As String Dim curr As String Dim plev As String Dim effdate As Date '----------------------pick price level--------------------------------------------------------------------- login.tbU = "report" login.tbP = "report" login.Show If Not login.proceed Then Exit Sub Call pricelevel.repopulate pricelevel.Show If pricelevel.cancel Then Exit Sub plev = pricelevel.tbPriceLev.text If Not IsDate(pricelevel.tbEddDate.text) Then MsgBox ("cannot interperet date - " & pricelevel.tbEddDate.text) Exit Sub End If effdate = CDate(pricelevel.tbEddDate.text) filepath = pricelevel.tbPATH & "\" & plev '---------------------get full code list-------------------------------------------------------------------- fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;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 fcws.Pictures.Insert("https://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.IncrementLeft 2 Selection.ShapeRange.IncrementTop 2 ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/" fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY") fcws.Name = "Full Code Listing" fcws.Cells(3, 1).Select 'Application.ScreenUpdating = True 'Exit Sub '---------------------get price list------------------------------------------------------------------------ pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm") If pl(0, 0) <> "Product" Then MsgBox (pl(0, 0)) Exit Sub End If '---------------------create new workbook------------------------------------------------------------------- Set nwb = Application.Workbooks.Add nwb.Activate Set nws = nwb.Sheets(1) nws.Activate nws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric Call x.SHTp_Dump(pl, nws.Name, 5, 1, False, True) Application.ScreenUpdating = False '---------------------whole sheet formatting---------------------------------------------------------------- nws.Columns(9).HorizontalAlignment = xlCenter nws.Columns(10).HorizontalAlignment = xlRight nws.Columns(11).HorizontalAlignment = xlRight nws.Columns(12).HorizontalAlignment = xlCenter nws.Columns(13).HorizontalAlignment = xlRight nws.Columns(14).HorizontalAlignment = xlRight nws.Columns(15).HorizontalAlignment = xlCenter 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 nws.Columns(8).ColumnWidth = 11 nws.Columns(9).ColumnWidth = 17.71 nws.Columns(12).ColumnWidth = 17.71 nws.Columns(15).ColumnWidth = 17.71 nws.Columns(10).ColumnWidth = 10.57 nws.Columns(13).ColumnWidth = 10.57 nws.Columns(16).ColumnWidth = 10.57 nws.Columns(11).ColumnWidth = 11.71 nws.Columns(14).ColumnWidth = 11.71 nws.Columns(17).ColumnWidth = 11.71 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://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select Selection.ShapeRange.ScaleHeight 0.6, 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 3 End With With nws.Range("L4") .value = "------------Full Pallet----------" .HorizontalAlignment = xlLeft .InsertIndent 3 End With With nws.Range("O4") .value = "------------Bulk Pallet----------" .HorizontalAlignment = xlLeft .InsertIndent 3 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) = "'" '--------------------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 Next i '--------------------print header data-------------------------------------------------------------------------- pl = x.TBLp_Transpose(pl) Call x.TBLp_FilterSingle(pl, 20, "", False) Call x.TBLp_Group(pl, True, x.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.Name = "Price List" nws.Cells(5, 1).Select Call print_setup(nws, last) nws.Columns("R:V").Delete 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 Dim wb As Workbook For Each wb In Workbooks If wb.Name = "HC Companies Distributor Price List.xlsx" Then If MsgBox("already have a price list open, close it?", vbOKCancel) Then Workbooks("HC Companies Distributor Price List.xlsx").Close Exit For Else Exit Sub End If End If Next wb If filepath <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx" 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 filepath <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx" 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 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 = 2 To last_row If j = 70 Then sheet.HPageBreaks.Add before:=sheet.Rows(i + 1) j = 1 End If 'every 73 rows is a page break for current font 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 + 1 Next i sheet.DisplayPageBreaks = False Application.PrintCommunication = True End Sub