Sub macro_borders_apa()
' - Stephen A. Burton (burtonstephena@gmail.com)
' - Free to use with attribution.
'
' 20180828
' Creates APA style table from Excel data.
' Change fonts and styles as required for your presentation or paper.
' Assumes data is at uppermost left in Excel with column headers in top row.
' Adds extra row at top for table title.
' Freezes top two rows for scrolling.
' Adds filters for data analysis. (Remove filters if desired.)
' Blanks borders on columns to right of last used.
' Sets zoom to 80%.
' Sets row height to 15.
' Copy this routine into new module in PERSONAL.XLSB to make available on Excel startup.
'
'
'
' select all used cells on worksheet
ActiveSheet.UsedRange.Copy
'
' apply fontstyle
' remove all existing boldface
ActiveSheet.UsedRange.Activate
With Selection.Font
.Name = "Segoe UI"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
.ThemeColor = xlThemeColorLight1
.Bold = True
.Bold = False
End With
'
' left justify header, center vertically
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'
' clear all existing borders
With Selection
Selection.borders(xlDiagonalDown).LineStyle = xlNone
Selection.borders(xlDiagonalUp).LineStyle = xlNone
Selection.borders(xlEdgeLeft).LineStyle = xlNone
Selection.borders(xlEdgeTop).LineStyle = xlNone
Selection.borders(xlEdgeBottom).LineStyle = xlNone
Selection.borders(xlEdgeRight).LineStyle = xlNone
Selection.borders(xlInsideVertical).LineStyle = xlNone
Selection.borders(xlInsideHorizontal).LineStyle = xlNone
End With
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'
' draw top borders
Rows("1:1").Select
Selection.borders(xlDiagonalDown).LineStyle = xlNone
Selection.borders(xlDiagonalUp).LineStyle = xlNone
Selection.borders(xlEdgeLeft).LineStyle = xlNone
With Selection.borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
Selection.borders(xlEdgeRight).LineStyle = xlNone
Selection.borders(xlInsideVertical).LineStyle = xlNone
Selection.borders(xlInsideHorizontal).LineStyle = xlNone
End With
'
' top border text bold
' add filters
With Selection.Font
.Bold = True
Selection.AutoFilter
End With
Cells.Select
'
' hide Excel gridlines
' freeze top row
ActiveWindow.DisplayGridlines = False
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
'
' insert row at top for table title
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
' set zoom = 80%
ActiveWindow.Zoom = 80
'
' draw bottom border on row (last row + 1)
Dim LastRow As Integer
LastRow = ActiveSheet.UsedRange.Rows.Count
LastRow = LastRow + 1
Rows(LastRow).Select
With Selection.borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
'
' blank borders on columns to right of last used
Dim LastCol As Integer
Dim FirstLetter As String
LastCol = ActiveSheet.UsedRange.Columns.Count
LastCol = LastCol + 1
FirstLetter = Split(ActiveSheet.Cells(, LastCol).Address, "$")(1)
Range(Range(FirstLetter + "1"), Range(FirstLetter + "1").End(xlDown).End(xlToRight)).Select
With Selection
Selection.borders(xlDiagonalDown).LineStyle = xlNone
Selection.borders(xlDiagonalUp).LineStyle = xlNone
Selection.borders(xlEdgeLeft).LineStyle = xlNone
Selection.borders(xlEdgeTop).LineStyle = xlNone
Selection.borders(xlEdgeBottom).LineStyle = xlNone
Selection.borders(xlEdgeRight).LineStyle = xlNone
Selection.borders(xlInsideVertical).LineStyle = xlNone
Selection.borders(xlInsideHorizontal).LineStyle = xlNone
End With
'
' set row height
ActiveSheet.UsedRange.Rows.RowHeight = 15
'
' autofit columns
Cells.EntireColumn.AutoFit
'
End Sub