Conditional formatting is a great tool, but after a spreadsheet has a lot of edits, the number of conditional rules spirals out of control.
To solve this I wrote a short VBA macro, which propagates conditional formatting (and only conditional formatting) from the top-most cell in each column. It’s a simplistic implementation, with the following restrictions:
- It replicates the formatting column-by-column, copying the conditional formatting from the first (top-most) cell which has some. Make sure that the rules you want propagated are topmost in the list and include that topmost cell before running.
- Corollary: It doesn’t handle multi-column formatting.
Paste the following code into a new module:
Option Explicit
Option Compare Text
Sub Test(xls As String)
' Open the workbook with conditional formatting.
' Test wookbookname
' in the immediate window
' this will merge the conditional formatting on the first worksheet of that book
Dim wb As Workbook
Set wb = Workbooks(xls)
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
MergeConditional ws
End Sub
Public Sub MergeConditional(ws As Worksheet)
On Error GoTo FAIL
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim lur As Long
lur = LastUsedRow(ws)
Dim luc As Long
luc = LastUsedCol(ws)
Dim col As Integer
Dim row As Long
For col = 1 To luc
Dim found As Boolean
found = False
Dim source As Range
For row = 1 To lur
Set source = ws.Cells(row, col)
If source.FormatConditions.Count > 0 Then
found = True
Exit For
End If
Next row
If found And row < lur Then
ws.Range(ws.Cells(row + 1, col), ws.Cells(1048576, col)).FormatConditions.Delete
Dim target As Range
Set target = ws.Range(ws.Cells(row, col), ws.Cells(lur, col))
Dim i As Integer
For i = 1 To source.FormatConditions.Count
source.FormatConditions(i).ModifyAppliesToRange target
Next i
End If ' found
Next col
FAIL:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function LastUsedCol(ws As Worksheet) As Long
On Error Resume Next
LastUsedCol = 1
LastUsedCol = ws.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
End Function
Private Function LastUsedRow(ws As Worksheet) As Long
On Error Resume Next
LastUsedRow = 1
LastUsedRow = ws.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).row
End Function
