more formatting

This commit is contained in:
Paul Trowbridge 2022-05-12 12:38:56 -04:00
parent 261aece1ad
commit 22af739ffb
1 changed files with 113 additions and 11 deletions

View File

@ -516,10 +516,11 @@ Sub build_pretty()
Set nwb = Application.Workbooks.Add
nwb.Activate
Set nws = nwb.Sheets(1)
Set nws.Name = "Price List"
nws.Activate
nws.Cells.NumberFormat = "@"
nws.Name = "USD"
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
@ -531,16 +532,37 @@ Sub build_pretty()
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
Columns("B:B").EntireColumn.autofit
Columns("A:A").ColumnWidth = 10.71
nws.Cells.Font.Name = "Cascadia Code Light"
nws.Cells.Font.Size = 10
Rows("6:6").Select
ActiveWindow.FreezePanes = True
nws.Cells(2, 3).value = "Distributor Price List (USD) - Effective 6/1/2022"
'---------------------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---------------------------------------------------------------------
@ -548,9 +570,21 @@ Sub build_pretty()
c.value = Left(c.value, Len(c.value) - 1)
Next c
Application.DisplayAlerts = False
nws.Range("I4:K4").MergeCells = True
nws.Range("L4:N4").MergeCells = True
nws.Range("O4:Q4").MergeCells = True
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---------------------------------------------------------------------
@ -562,13 +596,24 @@ Sub build_pretty()
lastcol = 17
'--------------------line formatting--------------------------------------------------------------------------
Application.ScreenUpdating = False
For i = 6 To last
If nws.Cells(i, 18) = "header" Then Call pretty_green(nws, i, 1, lastcol)
'--------------------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)
'----if the next row is different and the previous row is the same the loop back and merge the range------
'--------------------highlight price---------------
If nws.Cells(i, 18) <> "header" Then Call price_col(nws, i, 20)
'--------------------comment empy qty to prevent colors from spilling
If nws.Cells(i, 9) = "" Then nws.Cells(i, 9) = "'"
If nws.Cells(i, 11) = "" Then nws.Cells(i, 11) = "'"
If nws.Cells(i, 12) = "" Then nws.Cells(i, 12) = "'"
If nws.Cells(i, 14) = "" Then nws.Cells(i, 14) = "'"
If nws.Cells(i, 15) = "" 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
@ -577,8 +622,12 @@ Sub build_pretty()
If j < 0 Then Call merge(nws, i + j, i)
End If
Next i
nws.Columns("R:T").Delete
nws.Cells(5, 1).Select
Application.ScreenUpdating = True
Call page_setup
'--------------------save file--------------------------------------------------------------------------------
'prettyfilepath = "C:\Users\PTrowbridge\Downloads\PriceListPackage\" & "U.AAA.DI" & "\" & "HC Companies Distributor Price List.xlsx"
'Call nwb.SaveAs(prettyfilepath, "XLSX")
@ -592,6 +641,39 @@ Function rrange(ByRef sheet As Worksheet, start_row As Long, end_row As Long, st
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
@ -646,12 +728,14 @@ Sub banding(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Lo
End Sub
Sub pretty_green(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)
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
@ -691,5 +775,23 @@ Sub pretty_green(ByRef ws As Worksheet, row As Long, start_col As Long, end_col
End Sub
Sub print_setup(sheet As Worksheet, last_row As Long)
Dim Sel As Range
Set Sel = rrange(sheet, 6, last_row, 1, 17)
With sheet.PageSetup
.PrintArea = Sel.address
.PrintTitleRows = "$1:$5"
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.Orientation = xlLandscape
.FitToPagesWide = 1
End With
End Sub