VBA Formats

#### FORMATS Module

Option Explicit

'#####################################################################
'FormatTableRowHeadings  : Macro to format a table with headers on top
'i.e. Data in columns. This macro uses merged cells to identify
'headings. You may format the headings and content separately.
'Set HeaderFontBold to True to make the font bold. Choose RGB colours
'for HeaderFontColor, HeaderFillColor, ContentFontColor and
'ContentFillColor. ContentZebraTint accepts value between -1 and 1.
'Set it to 0 for no banding. Positive fractions lighten the alternate
'data rows and vice versa.
'#####################################################################
'Author     : Ejaz Ahmed
'Email      : StrugglingToExcel@outlook.com
'Date       : 02 June 2014
'Website    : http://strugglingtoexcel.wordpress.com/
'#####################################################################
Sub FormatTableRowHeadings(Optional ByRef WhichRange As Range, _
    Optional ByVal HeaderFontBold As Boolean = False, _
    Optional ByVal HeaderFontColor As XlRgbColor = rgbBlack, _
    Optional ByVal HeaderFillColor As XlRgbColor = xlNone, _
    Optional ByVal ContentFontColor As XlRgbColor = rgbBlack, _
    Optional ByVal ContentFillColor As XlRgbColor = xlNone, _
    Optional ByVal ContentZebraTint As Double = 0)

    'Declare Sub Level Variables and Objects
    Dim Table As Range
    Dim Header As Range
    Dim Contents As Range
    Dim EachCell As Range
    Dim HeaderRows As Long
    Dim TempInteger As Long
    Dim Counter As Long

    'Use the Active cell, if the user did not specify a range
    If WhichRange Is Nothing Then
        Set WhichRange = Application.ActiveCell
    End If

    'Initialize Variables
    HeaderRows = 1
    'Include the region surrounding the Range as well
    Set Table = WhichRange.CurrentRegion

    'Check if there are merged cells in the Top Row, and remember
    'the size
    For Each EachCell In Table.Rows(1).Cells
        If EachCell.MergeCells Then
            TempInteger = EachCell.MergeArea.Rows.Count
            If TempInteger > HeaderRows Then
                HeaderRows = TempInteger
            End If
        End If
    Next EachCell
    'Set the Top Row, including its merged cells as the Table's
    'Headings
    Set Header = Range(Table.Item(1, 1), _
        Table.Item(HeaderRows, Table.Columns.Count))

    'Apply the formatting to the header
    If Not Header Is Nothing Then
        'Make the headings bold
        Header.Font.Bold = HeaderFontBold
        'Add Color to the font
        Header.Font.Color = HeaderFontColor
        'Add fill colours to the cells
        Header.Interior.Color = HeaderFillColor
    End If

    'Check if the current region has data. This prevents an error from
    'occurring if the "table" is a single row header.
    If Table.Rows.Count > HeaderRows Then
        Set Contents = Table.Offset(HeaderRows).Resize( _
            Table.Rows.Count - HeaderRows)
    End If

    'If the current region did have more than just a header, go ahead
    'and format the data
    If Not Contents Is Nothing Then
        'Drag down number formats
        If Contents.Rows.Count > 1 Then
            For Counter = 1 To Contents.Columns.Count
                On Error Resume Next
                Contents.Columns(Counter).Cells(1, 1).AutoFill _
                    Contents.Columns(Counter).Cells, xlFillFormats
                On Error GoTo 0
            Next Counter
        End If
        'Add color to the font
        Contents.Font.Color = ContentFontColor
        'Add fill color to the cells
        Contents.Interior.Color = ContentFillColor
        'Add banding to the rows
        If Not ContentZebraTint = 0 Then
            For Counter = 2 To Contents.Rows.Count Step 2
                Contents.Rows(Counter).Cells. _
                    Interior.TintAndShade = ContentZebraTint
            Next Counter
        End If
    End If

End Sub


'#####################################################################
'FormatTableColumnHeadings  : Macro to format a table with headers on
'top i.e. Data in columns. This macro uses merged cells to identify
'headings. You may format the headings and content separately.
'Set HeaderFontBold to True to make the font bold. Choose RGB colours
'for HeaderFontColor, HeaderFillColor, ContentFontColor and
'ContentFillColor. ContentZebraTint accepts value between -1 and 1.
'Set it to 0 for no banding. Positive fractions lighten the alternate
'data columns and vice versa.
'#####################################################################
'Author     : Ejaz Ahmed
'Email      : StrugglingToExcel@outlook.com
'Date       : 02 June 2014
'Website    : http://strugglingtoexcel.wordpress.com/
'#####################################################################
Sub FormatTableColumnHeadings(Optional ByRef WhichRange As Range, _
    Optional ByVal HeaderFontBold As Boolean = False, _
    Optional ByVal HeaderFontColor As XlRgbColor = rgbBlack, _
    Optional ByVal HeaderFillColor As XlRgbColor = xlNone, _
    Optional ByVal ContentFontColor As XlRgbColor = rgbBlack, _
    Optional ByVal ContentFillColor As XlRgbColor = xlNone, _
    Optional ByVal ContentZebraTint As Double = 0)

    'Declare Sub Level Variables and Objects
    Dim Table As Range
    Dim Header As Range
    Dim Contents As Range
    Dim EachCell As Range
    Dim HeaderColumns As Long
    Dim TempInteger As Long
    Dim Counter As Long

    'Use the Active cell, if the user did not specify a range
    If WhichRange Is Nothing Then
        Set WhichRange = Application.ActiveCell
    End If

    'Initialize Variables
    HeaderColumns = 1
    'Include the region Surounding the Range as well
    Set Table = WhichRange.CurrentRegion

    'Check if there are merged cells in the First Column, and
    'remember the size
    For Each EachCell In Table.Columns(1).Cells
        If EachCell.MergeCells Then
            TempInteger = EachCell.MergeArea.Columns.Count
            If TempInteger > HeaderColumns Then
                HeaderColumns = TempInteger
            End If
        End If
    Next EachCell
    'Set the First Column, including its merged cells as the Table's
    'Headings
    Set Header = Range(Table.Item(1, 1), _
        Table.Item(Table.Rows.Count, HeaderColumns))

    'Apply the formatting to the header
    If Not Header Is Nothing Then
        'Make the headings bold
        Header.Font.Bold = HeaderFontBold
        'Add Color to the font
        Header.Font.Color = HeaderFontColor
        'Add fill colours to the cells
        Header.Interior.Color = HeaderFillColor
    End If

    'Check if the current region has data. This prevents an error from
    'occurring if the "table" is a single column header.
    If Table.Columns.Count > HeaderColumns Then
        Set Contents = Table.Offset(, HeaderColumns).Resize(, _
            Table.Columns.Count - HeaderColumns)
    End If

    'If the current region did have more than just a header, go ahead
    'and format the data
    If Not Contents Is Nothing Then
        'Drag to the right, the number formats
        If Contents.Columns.Count > 1 Then
            For Counter = 1 To Contents.Rows.Count
                On Error Resume Next
                    Contents.Rows(Counter).Cells(1, 1).AutoFill _
                        Contents.Rows(Counter).Cells, xlFillFormats
                On Error GoTo 0
            Next Counter
        End If
       'Add color to the font
        Contents.Font.Color = ContentFontColor
        'Add fill color to the cells
        Contents.Interior.Color = ContentFillColor
        'Add banding to the rows
        If Not ContentZebraTint = 0 Then
            For Counter = 2 To Contents.Columns.Count Step 2
                Contents.Columns(Counter).Cells. _
                    Interior.TintAndShade = ContentZebraTint
            Next Counter
        End If
    End If

End Sub

'#####################################################################
'AddTableBorders  : Macro to add borders to a table. First, set the
'Line Style, Weight, Colour and TinteAndShade. You may also choose to
'individually specify the boolean markers associated with each border.
'Specify the range and set TableLineStyle to xlNone to remove all
'borders.
'#####################################################################
'Author     : Ejaz Ahmed
'Email      : StrugglingToExcel@outlook.com
'Date       : 02 June 2014
'Website    : http://strugglingtoexcel.wordpress.com/
'#####################################################################
Sub AddTableBorders(Optional ByRef WhichRange As Range, _
    Optional ByVal TableLineStyle As XlLineStyle = xlContinuous, _
    Optional ByVal TableLineWeight As XlBorderWeight = xlThin, _
    Optional ByVal TableLineColor As XlRgbColor = rgbBlack, _
    Optional ByVal TableLineTint As Double = 0, _
    Optional ByVal TableEdgeLeft As Boolean = True, _
    Optional ByVal TableEdgeTop As Boolean = True, _
    Optional ByVal TableEdgeBottom As Boolean = True, _
    Optional ByVal TableEdgeRight As Boolean = True, _
    Optional ByVal TableInsideVertical As Boolean = True, _
    Optional ByVal TableInsideHorizontal As Boolean = True, _
    Optional ByVal TableDiagonalDown As Boolean = False, _
    Optional ByVal TableDiagonalUp As Boolean = False)

    'Declare Sub Level Variables and Objects
    Dim Table As Range
    Dim WhichBorder As Border

    'Use the Active cell, if the user did not specify a range
    If WhichRange Is Nothing Then
        Set WhichRange = Application.ActiveCell
    End If
    'Include the region Surounding the Range as well
    Set Table = WhichRange.CurrentRegion

    'If the user set TableLineStyle to xlNone, reset all the
    'border boolean markers to False
    If TableLineStyle = xlNone Or TableLineWeight = xlNone Then
        TableEdgeLeft = False
        TableEdgeTop = False
        TableEdgeBottom = False
        TableEdgeRight = False
        TableInsideVertical = False
        TableInsideHorizontal = False
        TableDiagonalDown = False
        TableDiagonalUp = False
    End If

    'Go through each border and apply the formats if the use chose to
    'have it in the table.

    'Left Edge
    Set WhichBorder = Table.Borders(xlEdgeLeft)
    If TableEdgeLeft Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'Top Edge
    Set WhichBorder = Table.Borders(xlEdgeTop)
    If TableEdgeTop Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'Bottom Edge
    Set WhichBorder = Table.Borders(xlEdgeBottom)
    If TableEdgeBottom Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'Right Edge
    Set WhichBorder = Table.Borders(xlEdgeRight)
    If TableEdgeRight Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'All the vertical lines in between
    Set WhichBorder = Table.Borders(xlInsideVertical)
    If TableInsideVertical Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'All the Horizantal lines in between
    Set WhichBorder = Table.Borders(xlInsideHorizontal)
    If TableInsideHorizontal Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'I included the diagonal lines just to romove them if someone,
    'edded it inadvertently.

    'Diagonal Down Lines
    Set WhichBorder = Table.Borders(xlDiagonalDown)
    If TableDiagonalDown Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

    'Diagonal Up Lines
    Set WhichBorder = Table.Borders(xlDiagonalUp)
    If TableDiagonalUp Then
        With WhichBorder
            .LineStyle = TableLineStyle
            .ColorIndex = TableLineColor
            .TintAndShade = TableLineTint
            .Weight = TableLineWeight
        End With
    Else
        WhichBorder.LineStyle = xlNone
    End If

End Sub




Sub BorderLineIfNotMerged()
    ' Ñêðèïò âûäåëÿåò ðàìêó òàáëèöû æèðíûì; âñå âíóòðåííèå ãðàíèöû îáû÷íûì;
    ' à ãîðèçîíòàëüíûå ãðàíèöû âíóòðè ñòðîê ñ îáúåäèí¸ííûìè ÿ÷åéêàìè - òîíêîé ëèíèåé

    Dim i As Long
    Selection.Borders.Color = vbBlack
    Selection.Borders.Color = xlContinuous
    Selection.Borders(xlEdgeBottom).Weight = xlMedium
    Selection.Borders(xlEdgeTop).Weight = xlMedium
    Selection.Borders(xlEdgeLeft).Weight = xlMedium
    Selection.Borders(xlEdgeRight).Weight = xlMedium
    Selection.Borders(xlInsideHorizontal).Weight = xlThin
    Selection.Borders(xlInsideVertical).Weight = xlThin

    For i = 1 To Selection.Count
        Debug.Print (Selection(i).MergeArea.Address)
        Debug.Print (Selection(i).Address)
        Debug.Print ("----")
      If Selection(i).MergeArea.Address <> Selection(i).Address Then
        ' Application.Intersect(Selection, Selection(i).MergeArea.EntireColumn).Borders(xlInsideVertical).Weight = xlHairline
        Application.Intersect(Selection, Selection(i).MergeArea.EntireRow).Borders(xlInsideHorizontal).Weight = xlHairline
      End If
    Next

End Sub


#### COVERS MODULE

Option Explicit

'#####################################################################
'Cover Macros
'#####################################################################

Sub ResetTableFormats()

    Call FormatTableRowHeadings
    Call AddTableBorders(, xlNone)

End Sub

Sub FormatRowCrimsonDark()

    Call FormatTableRowHeadings(, False, rgbWhite, RGB(45, 45, 45), _
            rgbWhite, rgbCrimson, 0.2)
    Call AddTableBorders

End Sub

Sub FormatRowGoldDark()

    Call FormatTableRowHeadings(, False, rgbWhite, RGB(45, 45, 45), _
            rgbBlack, rgbGold, 0.2)
    Call AddTableBorders

End Sub

Sub FormatColumnCrimsonDark()

    Call FormatTableColumnHeadings(, False, rgbWhite, RGB(45, 45, 45), _
            rgbWhite, rgbCrimson, 0.2)
    Call AddTableBorders

End Sub

Sub FormatColumnGoldDark()

    Call FormatTableColumnHeadings(, False, rgbWhite, RGB(45, 45, 45), _
            rgbBlack, rgbGold, 0.2)
    Call AddTableBorders

End Sub