Personal VBA

Lost old Personal.. so starting to collect new one..

Private Sub BorderRowOnTop(row As Long)

    With ActiveSheet.Rows(row).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
   
End Sub


Private Sub ColourRow(row As Integer, colourSet1 As Boolean, inSelectionOnly As Boolean)

    Dim r As Range
    If inSelectionOnly Then
        Set r = ActiveSheet.Range(ActiveSheet.Cells(row, Selection.Column), ActiveSheet.Cells(row, Selection.Columns(Selection.Columns.Count).Column))
    Else
        Set r = ActiveSheet.Rows(row)
    End If

    With r.Interior
        If colourSet1 Then
            If row Mod 2 = 0 Then
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            Else
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End If
        Else
            If row Mod 2 = 0 Then
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            Else
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End If
        End If
    End With
End Sub


Sub BorderRowsOnChange()

'   For a selected column, border rows when data changes

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    
    Set sel = Selection
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    val = Selection(1, 1).Value
    
    For Each c In sel
        If c.Value <> val Then
            val = c.Value
            BorderRowOnTop (c.row)
        End If
    Next c

End Sub

Sub ColourRowsInSelectionOnlyOnChangeInActiveColumn()

'   For a selected column, alternate coloured rows when data changes
'   Only alternate within selected range

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    Dim colourSet1 As Boolean
    
    Set sel = Selection
    colourSet1 = True
    colourSubSet1 = True
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    
    val = ActiveCell.Value
    Call ColourRow(ActiveCell.row, colourSet1, True)
    
    For Each c In sel
        If c.Value <> val And c.Column = ActiveCell.Column Then
            val = c.Value
            colourSet1 = Not (colourSet1)
        End If
        Call ColourRow(c.row, colourSet1, True)
    Next c

End Sub

Sub ColourCompleteRowsOnChange()

'   For a selected column, alternate coloured rows when data changes

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    Dim colourSet1 As Boolean
    
    Set sel = Selection
    colourSet1 = True
    colourSubSet1 = True
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    
    val = Selection(1, 1).Value
    
    For Each c In sel
        If c.Value <> val Then
            val = c.Value
            colourSet1 = Not (colourSet1)
        End If
        Call ColourRow(c.row, colourSet1, False)
    Next c

End Sub