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