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