CleverSnake

VBA Formats

Feb 16th, 2020
637
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #### FORMATS Module
  2.  
  3. Option Explicit
  4.  
  5. '#####################################################################
  6. 'FormatTableRowHeadings  : Macro to format a table with headers on top
  7. 'i.e. Data in columns. This macro uses merged cells to identify
  8. 'headings. You may format the headings and content separately.
  9. 'Set HeaderFontBold to True to make the font bold. Choose RGB colours
  10. 'for HeaderFontColor, HeaderFillColor, ContentFontColor and
  11. 'ContentFillColor. ContentZebraTint accepts value between -1 and 1.
  12. 'Set it to 0 for no banding. Positive fractions lighten the alternate
  13. 'data rows and vice versa.
  14. '#####################################################################
  15. 'Author     : Ejaz Ahmed
  16. 'Email      : StrugglingToExcel@outlook.com
  17. 'Date       : 02 June 2014
  18. 'Website    : http://strugglingtoexcel.wordpress.com/
  19. '#####################################################################
  20. Sub FormatTableRowHeadings(Optional ByRef WhichRange As Range, _
  21.     Optional ByVal HeaderFontBold As Boolean = False, _
  22.     Optional ByVal HeaderFontColor As XlRgbColor = rgbBlack, _
  23.     Optional ByVal HeaderFillColor As XlRgbColor = xlNone, _
  24.     Optional ByVal ContentFontColor As XlRgbColor = rgbBlack, _
  25.     Optional ByVal ContentFillColor As XlRgbColor = xlNone, _
  26.     Optional ByVal ContentZebraTint As Double = 0)
  27.    
  28.     'Declare Sub Level Variables and Objects
  29.    Dim Table As Range
  30.     Dim Header As Range
  31.     Dim Contents As Range
  32.     Dim EachCell As Range
  33.     Dim HeaderRows As Long
  34.     Dim TempInteger As Long
  35.     Dim Counter As Long
  36.    
  37.     'Use the Active cell, if the user did not specify a range
  38.    If WhichRange Is Nothing Then
  39.         Set WhichRange = Application.ActiveCell
  40.     End If
  41.    
  42.     'Initialize Variables
  43.    HeaderRows = 1
  44.     'Include the region surrounding the Range as well
  45.    Set Table = WhichRange.CurrentRegion
  46.    
  47.     'Check if there are merged cells in the Top Row, and remember
  48.    'the size
  49.    For Each EachCell In Table.Rows(1).Cells
  50.         If EachCell.MergeCells Then
  51.             TempInteger = EachCell.MergeArea.Rows.Count
  52.             If TempInteger > HeaderRows Then
  53.                 HeaderRows = TempInteger
  54.             End If
  55.         End If
  56.     Next EachCell
  57.     'Set the Top Row, including its merged cells as the Table's
  58.    'Headings
  59.    Set Header = Range(Table.Item(1, 1), _
  60.         Table.Item(HeaderRows, Table.Columns.Count))
  61.    
  62.     'Apply the formatting to the header
  63.    If Not Header Is Nothing Then
  64.         'Make the headings bold
  65.        Header.Font.Bold = HeaderFontBold
  66.         'Add Color to the font
  67.        Header.Font.Color = HeaderFontColor
  68.         'Add fill colours to the cells
  69.        Header.Interior.Color = HeaderFillColor
  70.     End If
  71.    
  72.     'Check if the current region has data. This prevents an error from
  73.    'occurring if the "table" is a single row header.
  74.    If Table.Rows.Count > HeaderRows Then
  75.         Set Contents = Table.Offset(HeaderRows).Resize( _
  76.             Table.Rows.Count - HeaderRows)
  77.     End If
  78.    
  79.     'If the current region did have more than just a header, go ahead
  80.    'and format the data
  81.    If Not Contents Is Nothing Then
  82.         'Drag down number formats
  83.        If Contents.Rows.Count > 1 Then
  84.             For Counter = 1 To Contents.Columns.Count
  85.                 On Error Resume Next
  86.                 Contents.Columns(Counter).Cells(1, 1).AutoFill _
  87.                     Contents.Columns(Counter).Cells, xlFillFormats
  88.                 On Error GoTo 0
  89.             Next Counter
  90.         End If
  91.         'Add color to the font
  92.        Contents.Font.Color = ContentFontColor
  93.         'Add fill color to the cells
  94.        Contents.Interior.Color = ContentFillColor
  95.         'Add banding to the rows
  96.        If Not ContentZebraTint = 0 Then
  97.             For Counter = 2 To Contents.Rows.Count Step 2
  98.                 Contents.Rows(Counter).Cells. _
  99.                     Interior.TintAndShade = ContentZebraTint
  100.             Next Counter
  101.         End If
  102.     End If
  103.  
  104. End Sub
  105.  
  106.  
  107. '#####################################################################
  108. 'FormatTableColumnHeadings  : Macro to format a table with headers on
  109. 'top i.e. Data in columns. This macro uses merged cells to identify
  110. 'headings. You may format the headings and content separately.
  111. 'Set HeaderFontBold to True to make the font bold. Choose RGB colours
  112. 'for HeaderFontColor, HeaderFillColor, ContentFontColor and
  113. 'ContentFillColor. ContentZebraTint accepts value between -1 and 1.
  114. 'Set it to 0 for no banding. Positive fractions lighten the alternate
  115. 'data columns and vice versa.
  116. '#####################################################################
  117. 'Author     : Ejaz Ahmed
  118. 'Email      : StrugglingToExcel@outlook.com
  119. 'Date       : 02 June 2014
  120. 'Website    : http://strugglingtoexcel.wordpress.com/
  121. '#####################################################################
  122. Sub FormatTableColumnHeadings(Optional ByRef WhichRange As Range, _
  123.     Optional ByVal HeaderFontBold As Boolean = False, _
  124.     Optional ByVal HeaderFontColor As XlRgbColor = rgbBlack, _
  125.     Optional ByVal HeaderFillColor As XlRgbColor = xlNone, _
  126.     Optional ByVal ContentFontColor As XlRgbColor = rgbBlack, _
  127.     Optional ByVal ContentFillColor As XlRgbColor = xlNone, _
  128.     Optional ByVal ContentZebraTint As Double = 0)
  129.  
  130.     'Declare Sub Level Variables and Objects
  131.    Dim Table As Range
  132.     Dim Header As Range
  133.     Dim Contents As Range
  134.     Dim EachCell As Range
  135.     Dim HeaderColumns As Long
  136.     Dim TempInteger As Long
  137.     Dim Counter As Long
  138.    
  139.     'Use the Active cell, if the user did not specify a range
  140.    If WhichRange Is Nothing Then
  141.         Set WhichRange = Application.ActiveCell
  142.     End If
  143.    
  144.     'Initialize Variables
  145.    HeaderColumns = 1
  146.     'Include the region Surounding the Range as well
  147.    Set Table = WhichRange.CurrentRegion
  148.    
  149.     'Check if there are merged cells in the First Column, and
  150.    'remember the size
  151.    For Each EachCell In Table.Columns(1).Cells
  152.         If EachCell.MergeCells Then
  153.             TempInteger = EachCell.MergeArea.Columns.Count
  154.             If TempInteger > HeaderColumns Then
  155.                 HeaderColumns = TempInteger
  156.             End If
  157.         End If
  158.     Next EachCell
  159.     'Set the First Column, including its merged cells as the Table's
  160.    'Headings
  161.    Set Header = Range(Table.Item(1, 1), _
  162.         Table.Item(Table.Rows.Count, HeaderColumns))
  163.    
  164.     'Apply the formatting to the header
  165.    If Not Header Is Nothing Then
  166.         'Make the headings bold
  167.        Header.Font.Bold = HeaderFontBold
  168.         'Add Color to the font
  169.        Header.Font.Color = HeaderFontColor
  170.         'Add fill colours to the cells
  171.        Header.Interior.Color = HeaderFillColor
  172.     End If
  173.    
  174.     'Check if the current region has data. This prevents an error from
  175.    'occurring if the "table" is a single column header.
  176.    If Table.Columns.Count > HeaderColumns Then
  177.         Set Contents = Table.Offset(, HeaderColumns).Resize(, _
  178.             Table.Columns.Count - HeaderColumns)
  179.     End If
  180.    
  181.     'If the current region did have more than just a header, go ahead
  182.    'and format the data
  183.    If Not Contents Is Nothing Then
  184.         'Drag to the right, the number formats
  185.        If Contents.Columns.Count > 1 Then
  186.             For Counter = 1 To Contents.Rows.Count
  187.                 On Error Resume Next
  188.                     Contents.Rows(Counter).Cells(1, 1).AutoFill _
  189.                         Contents.Rows(Counter).Cells, xlFillFormats
  190.                 On Error GoTo 0
  191.             Next Counter
  192.         End If
  193.        'Add color to the font
  194.        Contents.Font.Color = ContentFontColor
  195.         'Add fill color to the cells
  196.        Contents.Interior.Color = ContentFillColor
  197.         'Add banding to the rows
  198.        If Not ContentZebraTint = 0 Then
  199.             For Counter = 2 To Contents.Columns.Count Step 2
  200.                 Contents.Columns(Counter).Cells. _
  201.                     Interior.TintAndShade = ContentZebraTint
  202.             Next Counter
  203.         End If
  204.     End If
  205.  
  206. End Sub
  207.  
  208. '#####################################################################
  209. 'AddTableBorders  : Macro to add borders to a table. First, set the
  210. 'Line Style, Weight, Colour and TinteAndShade. You may also choose to
  211. 'individually specify the boolean markers associated with each border.
  212. 'Specify the range and set TableLineStyle to xlNone to remove all
  213. 'borders.
  214. '#####################################################################
  215. 'Author     : Ejaz Ahmed
  216. 'Email      : StrugglingToExcel@outlook.com
  217. 'Date       : 02 June 2014
  218. 'Website    : http://strugglingtoexcel.wordpress.com/
  219. '#####################################################################
  220. Sub AddTableBorders(Optional ByRef WhichRange As Range, _
  221.     Optional ByVal TableLineStyle As XlLineStyle = xlContinuous, _
  222.     Optional ByVal TableLineWeight As XlBorderWeight = xlThin, _
  223.     Optional ByVal TableLineColor As XlRgbColor = rgbBlack, _
  224.     Optional ByVal TableLineTint As Double = 0, _
  225.     Optional ByVal TableEdgeLeft As Boolean = True, _
  226.     Optional ByVal TableEdgeTop As Boolean = True, _
  227.     Optional ByVal TableEdgeBottom As Boolean = True, _
  228.     Optional ByVal TableEdgeRight As Boolean = True, _
  229.     Optional ByVal TableInsideVertical As Boolean = True, _
  230.     Optional ByVal TableInsideHorizontal As Boolean = True, _
  231.     Optional ByVal TableDiagonalDown As Boolean = False, _
  232.     Optional ByVal TableDiagonalUp As Boolean = False)
  233.  
  234.     'Declare Sub Level Variables and Objects
  235.    Dim Table As Range
  236.     Dim WhichBorder As Border
  237.    
  238.     'Use the Active cell, if the user did not specify a range
  239.    If WhichRange Is Nothing Then
  240.         Set WhichRange = Application.ActiveCell
  241.     End If
  242.     'Include the region Surounding the Range as well
  243.    Set Table = WhichRange.CurrentRegion
  244.    
  245.     'If the user set TableLineStyle to xlNone, reset all the
  246.    'border boolean markers to False
  247.    If TableLineStyle = xlNone Or TableLineWeight = xlNone Then
  248.         TableEdgeLeft = False
  249.         TableEdgeTop = False
  250.         TableEdgeBottom = False
  251.         TableEdgeRight = False
  252.         TableInsideVertical = False
  253.         TableInsideHorizontal = False
  254.         TableDiagonalDown = False
  255.         TableDiagonalUp = False
  256.     End If
  257.    
  258.     'Go through each border and apply the formats if the use chose to
  259.    'have it in the table.
  260.    
  261.     'Left Edge
  262.    Set WhichBorder = Table.Borders(xlEdgeLeft)
  263.     If TableEdgeLeft Then
  264.         With WhichBorder
  265.             .LineStyle = TableLineStyle
  266.             .ColorIndex = TableLineColor
  267.             .TintAndShade = TableLineTint
  268.             .Weight = TableLineWeight
  269.         End With
  270.     Else
  271.         WhichBorder.LineStyle = xlNone
  272.     End If
  273.    
  274.     'Top Edge
  275.    Set WhichBorder = Table.Borders(xlEdgeTop)
  276.     If TableEdgeTop Then
  277.         With WhichBorder
  278.             .LineStyle = TableLineStyle
  279.             .ColorIndex = TableLineColor
  280.             .TintAndShade = TableLineTint
  281.             .Weight = TableLineWeight
  282.         End With
  283.     Else
  284.         WhichBorder.LineStyle = xlNone
  285.     End If
  286.    
  287.     'Bottom Edge
  288.    Set WhichBorder = Table.Borders(xlEdgeBottom)
  289.     If TableEdgeBottom Then
  290.         With WhichBorder
  291.             .LineStyle = TableLineStyle
  292.             .ColorIndex = TableLineColor
  293.             .TintAndShade = TableLineTint
  294.             .Weight = TableLineWeight
  295.         End With
  296.     Else
  297.         WhichBorder.LineStyle = xlNone
  298.     End If
  299.    
  300.     'Right Edge
  301.    Set WhichBorder = Table.Borders(xlEdgeRight)
  302.     If TableEdgeRight Then
  303.         With WhichBorder
  304.             .LineStyle = TableLineStyle
  305.             .ColorIndex = TableLineColor
  306.             .TintAndShade = TableLineTint
  307.             .Weight = TableLineWeight
  308.         End With
  309.     Else
  310.         WhichBorder.LineStyle = xlNone
  311.     End If
  312.    
  313.     'All the vertical lines in between
  314.    Set WhichBorder = Table.Borders(xlInsideVertical)
  315.     If TableInsideVertical Then
  316.         With WhichBorder
  317.             .LineStyle = TableLineStyle
  318.             .ColorIndex = TableLineColor
  319.             .TintAndShade = TableLineTint
  320.             .Weight = TableLineWeight
  321.         End With
  322.     Else
  323.         WhichBorder.LineStyle = xlNone
  324.     End If
  325.    
  326.     'All the Horizantal lines in between
  327.    Set WhichBorder = Table.Borders(xlInsideHorizontal)
  328.     If TableInsideHorizontal Then
  329.         With WhichBorder
  330.             .LineStyle = TableLineStyle
  331.             .ColorIndex = TableLineColor
  332.             .TintAndShade = TableLineTint
  333.             .Weight = TableLineWeight
  334.         End With
  335.     Else
  336.         WhichBorder.LineStyle = xlNone
  337.     End If
  338.    
  339.     'I included the diagonal lines just to romove them if someone,
  340.    'edded it inadvertently.
  341.    
  342.     'Diagonal Down Lines
  343.    Set WhichBorder = Table.Borders(xlDiagonalDown)
  344.     If TableDiagonalDown Then
  345.         With WhichBorder
  346.             .LineStyle = TableLineStyle
  347.             .ColorIndex = TableLineColor
  348.             .TintAndShade = TableLineTint
  349.             .Weight = TableLineWeight
  350.         End With
  351.     Else
  352.         WhichBorder.LineStyle = xlNone
  353.     End If
  354.    
  355.     'Diagonal Up Lines
  356.    Set WhichBorder = Table.Borders(xlDiagonalUp)
  357.     If TableDiagonalUp Then
  358.         With WhichBorder
  359.             .LineStyle = TableLineStyle
  360.             .ColorIndex = TableLineColor
  361.             .TintAndShade = TableLineTint
  362.             .Weight = TableLineWeight
  363.         End With
  364.     Else
  365.         WhichBorder.LineStyle = xlNone
  366.     End If
  367.  
  368. End Sub
  369.  
  370.  
  371.  
  372.  
  373. Sub BorderLineIfNotMerged()
  374.     ' Ñêðèïò âûäåëÿåò ðàìêó òàáëèöû æèðíûì; âñå âíóòðåííèå ãðàíèöû îáû÷íûì;
  375.    ' à ãîðèçîíòàëüíûå ãðàíèöû âíóòðè ñòðîê ñ îáúåäèí¸ííûìè ÿ÷åéêàìè - òîíêîé ëèíèåé
  376.    
  377.     Dim i As Long
  378.     Selection.Borders.Color = vbBlack
  379.     Selection.Borders.Color = xlContinuous
  380.     Selection.Borders(xlEdgeBottom).Weight = xlMedium
  381.     Selection.Borders(xlEdgeTop).Weight = xlMedium
  382.     Selection.Borders(xlEdgeLeft).Weight = xlMedium
  383.     Selection.Borders(xlEdgeRight).Weight = xlMedium
  384.     Selection.Borders(xlInsideHorizontal).Weight = xlThin
  385.     Selection.Borders(xlInsideVertical).Weight = xlThin
  386.    
  387.     For i = 1 To Selection.Count
  388.         Debug.Print (Selection(i).MergeArea.Address)
  389.         Debug.Print (Selection(i).Address)
  390.         Debug.Print ("----")
  391.       If Selection(i).MergeArea.Address <> Selection(i).Address Then
  392.         ' Application.Intersect(Selection, Selection(i).MergeArea.EntireColumn).Borders(xlInsideVertical).Weight = xlHairline
  393.        Application.Intersect(Selection, Selection(i).MergeArea.EntireRow).Borders(xlInsideHorizontal).Weight = xlHairline
  394.       End If
  395.     Next
  396.    
  397. End Sub
  398.  
  399.  
  400. #### COVERS MODULE
  401.  
  402. Option Explicit
  403.  
  404. '#####################################################################
  405. 'Cover Macros
  406. '#####################################################################
  407.  
  408. Sub ResetTableFormats()
  409.  
  410.     Call FormatTableRowHeadings
  411.     Call AddTableBorders(, xlNone)
  412.  
  413. End Sub
  414.  
  415. Sub FormatRowCrimsonDark()
  416.  
  417.     Call FormatTableRowHeadings(, False, rgbWhite, RGB(45, 45, 45), _
  418.             rgbWhite, rgbCrimson, 0.2)
  419.     Call AddTableBorders
  420.  
  421. End Sub
  422.  
  423. Sub FormatRowGoldDark()
  424.  
  425.     Call FormatTableRowHeadings(, False, rgbWhite, RGB(45, 45, 45), _
  426.             rgbBlack, rgbGold, 0.2)
  427.     Call AddTableBorders
  428.  
  429. End Sub
  430.  
  431. Sub FormatColumnCrimsonDark()
  432.  
  433.     Call FormatTableColumnHeadings(, False, rgbWhite, RGB(45, 45, 45), _
  434.             rgbWhite, rgbCrimson, 0.2)
  435.     Call AddTableBorders
  436.  
  437. End Sub
  438.  
  439. Sub FormatColumnGoldDark()
  440.  
  441.     Call FormatTableColumnHeadings(, False, rgbWhite, RGB(45, 45, 45), _
  442.             rgbBlack, rgbGold, 0.2)
  443.     Call AddTableBorders
  444.  
  445. End Sub
RAW Paste Data