CODEWITHSUNDEEP
vbaexcel
anəˈnimədē
anəˈnimədē

Reputation: 113

Clean Conditional Formatting (Excel VBA)

I apologize if this has been answered already but I was unable to find it. Here's what I want: We all know that deleting ranges, rows, and columns will split conditional formatting and make it hideous. I'd like to create a personal macro that:

1.) Searches through all existing Conditional Formatting in the active sheet
2.) Recognizes duplicates based on their condition and format result
3.) Finds the leftmost column and highest row in all duplicates
4.) Finds the rightmost column and lowest row in all duplicates
5.) Determines a broadened Range using those four values
6.) Remembers the condition and format
7.) Deletes all duplicates
8.) Recreates the Conditional Format over the broadened Range
9.) Repeats until no more duplicates are found
10) Outputs how many duplicates were deleted in a MsgBox

I'm 50% confident I could do this myself, but I have a feeling I'll need to learn how to work with array variables. (Of which I'm completely ignorant and thus terrified) So if anyone has already created this, then I beg you to share your genius. Or if anyone thinks they can whip this out, I offer you the chance to create what might become one of if not the most commonly included tool of the entire population of personal macro users (Right up there with Ctrl+Shift+V).

Or if nobody has or wants to, then maybe a few tips??? C'mon throw me a bone here!

Upvotes: 3

Views: 6290

Answers (3)

Christopher Rath
Christopher Rath

Reputation: 31

Here's my answer to this question. I have only implemented it for conditional formatting that uses a formula as I rarely use the other conditional format types. It's also available as an add-in from my personal website: MergeConditionalFormatting v1.2

Here's the code:

'''
' MergeConditionalFormatting - Add-in to merge conditional formatting.
' Author: Christopher Rath <[email protected]>
' Date: 2020-12-17
' Version: 1.0
' Archived at: http://www.rath.ca/Misc/VBA/
' Copyright © 2020 Christopher Rath
' Distributed under the GNU Lesser General Public License v2.1
' Warranty: None, see the license.
'''
Option Explicit
Option Base 1

' See https://learn.microsoft.com/en-us/office/vba/api/excel.formatcondition

Public Sub MergeCF()
    Dim cfBase As Object
    Dim cfCmp As Object
    Dim iBase, iCmp As Integer
    Dim delCount As Integer
    
    Application.ScreenUpdating = False
    
    delCount = 0
    
    With ActiveSheet.Cells
        'Debug.Print "Base", "Applies To", "Type", "Formula", "|", "Match", "|", "Cmp", "Applies To", "Type", "Formula"
        iBase = 1
        Do While iBase <= .FormatConditions.Count
            Set cfBase = .FormatConditions.Item(iBase)
            
            Application.StatusBar = "Checking FormatCondition " & iBase
            
            If (cfBase.Type = xlCellValue) Or (cfBase.Type = xlExpression) Then
                For iCmp = .FormatConditions.Count To (iBase + 1) Step -1
                    Application.StatusBar = "Checking FormatCondition " & iBase & " to " & iCmp
                
                    Set cfCmp = .FormatConditions.Item(iCmp)
                    
                    'Debug.Print iBase, cfBase.AppliesTo.Address(, , xlR1C1), cfBase.Type, _
                    '            Application.ConvertFormula(cfBase.Formula1, xlA1, xlR1C1, , _
                    '                                       cfBase.AppliesTo.Cells(1, 1)), _
                    '            "|", IIf(cmpFormatConditions(cfBase, cfCmp), "True", "False"), "|", _
                    '            iCmp, cfCmp.AppliesTo.Address(, , xlR1C1), cfCmp.Type, _
                    '            Application.ConvertFormula(cfCmp.Formula1, xlA1, xlR1C1, , _
                    '                                       cfCmp.AppliesTo.Cells(1, 1))
                    
                    If (cfCmp.Type = xlCellValue) Or (cfCmp.Type = xlExpression) Then
                        If cmpFormatConditions(cfBase, cfCmp) Then
                            cfBase.ModifyAppliesToRange Union(cfCmp.AppliesTo, cfBase.AppliesTo, cfCmp.AppliesTo)
                            cfCmp.Delete
                            delCount = delCount + 1
                            ' Testing has shown that the .Delete of the extra FormatCondition has caused the
                            ' FormatConditions collection to become changed; e.g., item(1) is no longer
                            ' guaranteed to be the same FormatCondition object that it was prior to the
                            ' .Delete.  So, we will now re-jig the value if iBase so that it restarts at
                            ' item(1) and once once again starts its scan from scratch.
                            iBase = 1
                            GoTo RESTART
                        End If
                    End If
                Next iCmp
            End If
            iBase = iBase + 1
RESTART:
        Loop
    End With
    
    Application.ScreenUpdating = True
    Application.StatusBar = "Consolidated " & delCount & " FormatCondition records."
End Sub

Private Function cmpFormatConditions(ByRef cfBase As FormatCondition, ByRef cfCmp As FormatCondition, _
                                     Optional ByVal comparePriority As Boolean = False) As Boolean
    Dim rtnVal As Boolean
    
    ' We set the return value (rtnVal) to false, and then test each property.
    ' If any individual test evaluates to false then we fall to the bottom of the if-thens
    ' and return the initial value (false).  If we make it through all the tests, then we
    ' change rtnVal to true before returning.
    '
    ' We test each property in reverse alphabetic order because most of the simple types are then tested
    ' first; which should speed up the code.
    '
    ' NOTE: The Priority property cannot be compared because this is simply the number that reflects
    '       the order in which the FormatCondition records are evaluated.  That said, we do allow this
    '       to behaviour to be overridden through an optional parameter.
    '
    rtnVal = False
    
    If cfBase.Type = cfCmp.Type Then
        ' The specific properties to test is dependent upon the Type.
        Select Case cfBase.Type
            Case xlCellValue, xlExpression
                If cfBase.StopIfTrue = cfCmp.StopIfTrue Then
                    If cfBase.PTCondition = cfCmp.PTCondition Then
                        If (Not comparePriority) Or (comparePriority And cfBase.Priority = cfCmp.Priority) Then
                            If cmpNumberFormat(cfBase.NumberFormat, cfCmp.NumberFormat) Then
                                If cmpInterior(cfBase.Interior, cfCmp.Interior) Then
                                    If Application.ConvertFormula(cfBase.Formula1, xlA1, xlR1C1, , cfBase.AppliesTo.Cells(1, 1)) _
                                          = Application.ConvertFormula(cfCmp.Formula1, xlA1, xlR1C1, , cfCmp.AppliesTo.Cells(1, 1)) Then
                                        If cmpFont(cfBase.Font, cfCmp.Font) Then
                                            If cmpBorders(cfBase.Borders, cfCmp.Borders) Then
                                                rtnVal = True
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
             
             Case Else
                ' Ultimately we need to throw a hard error.
                rtnVal = False
        End Select
    End If
        
    cmpFormatConditions = rtnVal
End Function

Private Function cmpBackground(ByRef bBase As Variant, ByRef bCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(bBase) And IsNull(bCmp) Then
        rtnVal = True
    ElseIf Not IsNull(bBase) And Not IsNull(bCmp) Then
        If bBase = bCmp Then
            rtnVal = True
        End If
    End If
    
    cmpBackground = rtnVal
End Function

Private Function cmpBold(ByRef bBase As Variant, ByRef bCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(bBase) And IsNull(bCmp) Then
        rtnVal = True
    ElseIf Not IsNull(bBase) And Not IsNull(bCmp) Then
        If bBase = bCmp Then
            rtnVal = True
        End If
    End If
    
    cmpBold = rtnVal
End Function

Private Function cmpBorder(ByRef bBase As Border, ByRef bCmp As Border) As Boolean
    Dim rtnVal As Boolean

    rtnVal = False
    
    If bBase.Color = bCmp.Color Then
        If bBase.ColorIndex = bCmp.ColorIndex Then
            If Not IsObject(bBase.ThemeColor) And Not IsObject(bCmp.ThemeColor) Then
                rtnVal = True
            ElseIf (Not IsObject(bBase.ThemeColor)) And (Not IsObject(bCmp.ThemeColor)) Then
                If bBase.ThemeColor = bCmp.ThemeColor Then
                    If bBase.Weight = bCmp.Weight Then
                        If bBase.LineStyle = bCmp.LineStyle Then
                            If bBase.TintAndShade = bCmp.TintAndShade Then
                                rtnVal = True
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
    cmpBorder = rtnVal
End Function

Private Function cmpBorders(ByRef bBase As Borders, ByRef bCmp As Borders) As Boolean
    Dim rtnVal As Boolean

    rtnVal = False
    
    If cmpBorder(bBase(xlDiagonalDown), bCmp(xlDiagonalDown)) Then
        If cmpBorder(bBase(xlDiagonalUp), bCmp(xlDiagonalUp)) Then
            If cmpBorder(bBase(xlEdgeBottom), bCmp(xlEdgeBottom)) Then
                If cmpBorder(bBase(xlEdgeLeft), bCmp(xlEdgeLeft)) Then
                    If cmpBorder(bBase(xlEdgeRight), bCmp(xlEdgeRight)) Then
                        If cmpBorder(bBase(xlEdgeTop), bCmp(xlEdgeTop)) Then
                            If cmpBorder(bBase(xlInsideHorizontal), bCmp(xlInsideHorizontal)) Then
                                If cmpBorder(bBase(xlInsideVertical), bCmp(xlInsideVertical)) Then
                                    rtnVal = True
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
    cmpBorders = rtnVal
End Function

Private Function cmpColor(ByRef cBase As Variant, ByRef cCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(cBase) And IsNull(cCmp) Then
        rtnVal = True
    ElseIf Not IsNull(cBase) And Not IsNull(cCmp) Then
        If cBase = cCmp Then
            rtnVal = True
        End If
    End If
    
    cmpColor = rtnVal
End Function

Private Function cmpColorIndex(ByRef cBase As Variant, ByRef cCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(cBase) And IsNull(cCmp) Then
        rtnVal = True
    ElseIf Not IsNull(cBase) And Not IsNull(cCmp) Then
        If cBase = cCmp Then
            rtnVal = True
        End If
    End If
    
    cmpColorIndex = rtnVal
End Function

Private Function cmpFont(ByRef fBase As Font, ByRef fCmp As Font) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    ' Is a Font object and so I need to build out tests for its properties.
    If cmpBackground(fBase.Background, fCmp.Background) Then
        If cmpBold(fBase.Bold, fCmp.Bold) Then
            If cmpColor(fBase.Color, fCmp.Color) Then
                If cmpColorIndex(fBase.ColorIndex, fCmp.ColorIndex) Then
                    If cmpFontStyle(fBase.FontStyle, fCmp.FontStyle) Then
                        If cmpItalic(fBase.Italic, fCmp.Italic) Then
                            If cmpName(fBase.Name, fCmp.Name) Then
                                If cmpSize(fBase.Size, fCmp.Size) Then
                                    If cmpStrikethrough(fBase.Size, fCmp.Size) Then
                                        If cmpSubscript(fBase.Size, fCmp.Size) Then
                                            If cmpSuperscript(fBase.Size, fCmp.Size) Then
                                                If cmpThemeColor_V(fBase, fCmp) Then
                                                    If fBase.ThemeFont = fCmp.ThemeFont Then
                                                        If cmpTintAndShade(fBase.TintAndShade, fCmp.TintAndShade) Then
                                                            If cmpUnderline(fBase.Underline, fCmp.Underline) Then
                                                                rtnVal = True
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
    cmpFont = rtnVal
End Function

Private Function cmpFontStyle(ByRef fBase As Variant, ByRef fCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(fBase) And IsNull(fCmp) Then
        rtnVal = True
    ElseIf Not IsNull(fBase) And Not IsNull(fCmp) Then
        If fBase = fCmp Then
            rtnVal = True
        End If
    End If
    
    cmpFontStyle = rtnVal
End Function

Private Function cmpGradient(ByRef gBase As Variant, ByRef gCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If (gBase Is Nothing) And (gCmp Is Nothing) Then
        rtnVal = True
    ElseIf Not (gBase Is Nothing) And Not (gCmp Is Nothing) Then
        If gBase = gCmp Then
            rtnVal = True
        End If
    End If
    
    cmpGradient = rtnVal
End Function

Private Function cmpInterior(ByRef iBase As Interior, ByRef iCmp As Interior) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If iBase.Color = iCmp.Color Then
        If cmpColorIndex(iBase.ColorIndex, iCmp.ColorIndex) Then
            If cmpGradient(iBase.Gradient, iCmp.Gradient) Then
                If cmpPattern(iBase.Pattern, iCmp.Pattern) Then
                    If cmpPatternColor(iBase.PatternColor, iCmp.PatternColor) Then
                        If cmpPatternColorIndex(iBase.PatternColorIndex, iCmp.PatternColorIndex) Then
                            If cmpPatternThemeColor(iBase.PatternThemeColor, iCmp.PatternThemeColor) Then
                                If cmpPatternTintAndShade(iBase.PatternTintAndShade, iCmp.PatternTintAndShade) Then
                                    If cmpThemeColor_V(iBase, iCmp) Then
                                        If cmpTintAndShade(iBase.TintAndShade, iCmp.TintAndShade) Then
                                            rtnVal = True
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
    cmpInterior = rtnVal
End Function

Private Function cmpItalic(ByRef iBase As Variant, ByRef iCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(iBase) And IsNull(iCmp) Then
        rtnVal = True
    ElseIf Not IsNull(iBase) And Not IsNull(iCmp) Then
        If iBase = iCmp Then
            rtnVal = True
        End If
    End If
    
    cmpItalic = rtnVal
End Function

Private Function cmpName(ByRef nBase As Variant, ByRef nCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(nBase) And IsNull(nCmp) Then
        rtnVal = True
    ElseIf Not IsNull(nBase) And Not IsNull(nCmp) Then
        If nBase = nCmp Then
            rtnVal = True
        End If
    End If
    
    cmpName = rtnVal
End Function

Private Function cmpNumberFormat(ByRef nfBase As Variant, ByRef nfCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsEmpty(nfBase) And IsEmpty(nfCmp) Then
        rtnVal = True
    ElseIf (Not IsEmpty(nfBase)) And (Not IsEmpty(nfCmp)) Then
        If nfBase = nfCmp Then
            rtnVal = True
        End If
    End If
    
    cmpNumberFormat = rtnVal
End Function

Private Function cmpPattern(ByRef pBase As Variant, ByRef pCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(pBase) And IsNull(pCmp) Then
        rtnVal = True
    ElseIf Not IsNull(pBase) And Not IsNull(pCmp) Then
        If pBase = pCmp Then
            rtnVal = True
        End If
    End If
    
    cmpPattern = rtnVal
End Function

Private Function cmpPatternColor(ByRef pBase As Variant, ByRef pCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(pBase) And IsNull(pCmp) Then
        rtnVal = True
    ElseIf Not IsNull(pBase) And Not IsNull(pCmp) Then
        If pBase = pCmp Then
            rtnVal = True
        End If
    End If
    
    cmpPatternColor = rtnVal
End Function

Private Function cmpPatternColorIndex(ByRef pBase As Variant, ByRef pCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(pBase) And IsNull(pCmp) Then
        rtnVal = True
    ElseIf Not IsNull(pBase) And Not IsNull(pCmp) Then
        If pBase = pCmp Then
            rtnVal = True
        End If
    End If
    
    cmpPatternColorIndex = rtnVal
End Function

Private Function cmpPatternThemeColor(ByRef pBase As Variant, ByRef pCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(pBase) And IsNull(pCmp) Then
        rtnVal = True
    ElseIf Not IsNull(pBase) And Not IsNull(pCmp) Then
        If pBase = pCmp Then
            rtnVal = True
        End If
    End If
    
    cmpPatternThemeColor = rtnVal
End Function

Private Function cmpPatternTintAndShade(ByRef pBase As Variant, ByRef pCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(pBase) And IsNull(pCmp) Then
        rtnVal = True
    ElseIf Not IsNull(pBase) And Not IsNull(pCmp) Then
        If pBase = pCmp Then
            rtnVal = True
        End If
    End If
    
    cmpPatternTintAndShade = rtnVal
End Function

Private Function cmpSize(ByRef sBase As Variant, ByRef sCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(sBase) And IsNull(sCmp) Then
        rtnVal = True
    ElseIf Not IsNull(sBase) And Not IsNull(sCmp) Then
        If sBase = sCmp Then
            rtnVal = True
        End If
    End If
    
    cmpSize = rtnVal
End Function

Private Function cmpStrikethrough(ByRef sBase As Variant, ByRef sCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(sBase) And IsNull(sCmp) Then
        rtnVal = True
    ElseIf Not IsNull(sBase) And Not IsNull(sCmp) Then
        If sBase = sCmp Then
            rtnVal = True
        End If
    End If
    
    cmpStrikethrough = rtnVal
End Function

Private Function cmpSubscript(ByRef sBase As Variant, ByRef sCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(sBase) And IsNull(sCmp) Then
        rtnVal = True
    ElseIf Not IsNull(sBase) And Not IsNull(sCmp) Then
        If sBase = sCmp Then
            rtnVal = True
        End If
    End If
    
    cmpSubscript = rtnVal
End Function

Private Function cmpSuperscript(ByRef sBase As Variant, ByRef sCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(sBase) And IsNull(sCmp) Then
        rtnVal = True
    ElseIf Not IsNull(sBase) And Not IsNull(sCmp) Then
        If sBase = sCmp Then
            rtnVal = True
        End If
    End If
    
    cmpSuperscript = rtnVal
End Function

Private Function cmpThemeColor_V(ByRef vBase As Variant, ByRef vCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    Dim baseErr, cmpErr As Boolean
    
    baseErr = False
    cmpErr = False
    rtnVal = False
    
    On Error GoTo ERR_BASE
    ' Force an evaluation of fcBase.ThemeColor.  We only care if it was possible to read the property
    ' without generating an error.
    If IsNull(vBase.ThemeColor) Then
        ' Empty clause.
    End If
   
    On Error GoTo ERR_CMP
    ' Force an evaluation of fcBase.ThemeColor.  We only care if it was possible to read the property
    ' without generating an error.
    If IsNull(vCmp.ThemeColor) Then
        ' Empty clause.
    End If
       
    On Error GoTo 0
    
    If baseErr And cmpErr Then
        rtnVal = True
    ElseIf (Not baseErr) And (Not cmpErr) Then
        If IsNull(vBase.ThemeColor) And IsNull(vCmp.ThemeColor) Then
            rtnVal = True
        ElseIf Not IsNull(vBase.ThemeColor) And Not IsNull(vCmp.ThemeColor) Then
            If vBase.ThemeColor = vCmp.ThemeColor Then
                rtnVal = True
            End If
        End If
    End If

    cmpThemeColor_V = rtnVal
    Exit Function
    
ERR_BASE:
    On Error Resume Next
    baseErr = True
    Resume
ERR_CMP:
    On Error Resume Next
    cmpErr = True
    Resume
End Function

Private Function cmpTintAndShade(ByRef tbase As Variant, ByRef tcmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(tbase) And IsNull(tcmp) Then
        rtnVal = True
    ElseIf Not IsNull(tbase) And Not IsNull(tcmp) Then
        If tbase = tcmp Then
            rtnVal = True
        End If
    End If
    
    cmpTintAndShade = rtnVal
End Function

Private Function cmpUnderline(ByRef uBase As Variant, ByRef uCmp As Variant) As Boolean
    Dim rtnVal As Boolean
    
    rtnVal = False
    
    If IsNull(uBase) And IsNull(uCmp) Then
        rtnVal = True
    ElseIf Not IsNull(uBase) And Not IsNull(uCmp) Then
        If uBase = uCmp Then
            rtnVal = True
        End If
    End If
    cmpUnderline = rtnVal
End Function

Upvotes: 3

paul bica
paul bica

Reputation: 10715

This is an incomplete attempt to make it as generic as possible (provided as a starting point only)

Option Explicit

Private Const SP As String = "||"   'string delimiter, or SeParator

Public Sub x()
    resetConditionalFormatting Sheet1.UsedRange
End Sub

Public Sub resetConditionalFormatting(Optional ByRef rng As Range = Nothing)
    Const FIRST_ROW As Long = 2

    Dim colRng As Range, thisCol As Long, fc As FormatCondition, thisFC As Long
    Dim maxCell As Range, ws As Worksheet, cell1 As Range, cell2 As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    Set ws = rng.Parent
    Set maxCell = GetMaxCell(rng)

    If maxCell.Row > 1 Or maxCell.Column > 1 Or Len(maxCell) > 0 Then
        thisCol = 1
        Set cell1 = ws.Cells(FIRST_ROW, thisCol)
        Set cell2 = ws.Cells(maxCell.Row, thisCol)
        For Each colRng In rng.Columns
            thisFC = 1
            For Each fc In colRng.FormatConditions
                fc.ModifyAppliesToRange ws.Range(cell1, cell2)
                thisFC = thisFC + 1
            Next
            thisCol = thisCol + 1
        Next
    End If
End Sub

Private Sub fcDupe(ByRef fc As Variant, ByRef fcType() As String, ByRef dupes As Long)
    Dim tStr As String, itm As Variant, fcT As Byte

    On Error Resume Next    'some properties may not be defined at runtime
    With fc

        fcT = .Type

    tStr = SP
    'Border, Font, and Interior apply to 1, 2, 5, 8, 9, 10, 11, 12, 13, 16, 17
    tStr = tStr & CStr(ObjPtr(.Borders)) & _
                  CStr(ObjPtr(.Font)) & _
                  CStr(ObjPtr(.Interior))
    'CStr(ObjPtr(fc)): https://support2.microsoft.com/default.aspx?scid=kb;en-us;199824

        Select Case fcT
            Case xlCellValue                '1
                tStr = tStr & .DateOperator
                tStr = tStr & .Formula1
                tStr = tStr & .Formula2
                tStr = tStr & .Operator
                tStr = tStr & .ScopeType
                tStr = tStr & .Text
                tStr = tStr & .TextOperator
                tStr = tStr & SP
            Case xlColorScale               '3
                tStr = SP & CStr(ObjPtr(.ColorScaleCriteria))
                tStr = tStr & .Formula
                tStr = tStr & .ScopeType
                tStr = tStr & SP
            Case xlDatabar                  '4
                tStr = SP & CStr(ObjPtr(.AxisColor)) & _
                            CStr(ObjPtr(.BarBorder)) & _
                            CStr(ObjPtr(.BarColor)) & _
                            CStr(ObjPtr(.MaxPoint)) & _
                            CStr(ObjPtr(.MinPoint)) & _
                            CStr(ObjPtr(.NegativeBarFormat))
                tStr = tStr & .AxisPosition
                tStr = tStr & .BarFillType
                tStr = tStr & .Direction
                tStr = tStr & .Formula
                tStr = tStr & .PercentMax
                tStr = tStr & .PercentMin
                tStr = tStr & .ScopeType
                tStr = tStr & .ShowValue
                tStr = tStr & SP
            Case xlTop10                    '5
                tStr = tStr & .CalcFor
                tStr = tStr & .Percent
                tStr = tStr & .Rank
                tStr = tStr & .TopBottom
                tStr = tStr & .ScopeType
                tStr = tStr & SP
            Case 6                          'XlFormatConditionType.xlIconSet
                tStr = SP & CStr(ObjPtr(.IconCriteria)) & CStr(ObjPtr(.IconSet))
                tStr = tStr & .Formula
                tStr = tStr & .PercentValue
                tStr = tStr & .ReverseOrder
                tStr = tStr & .ScopeType
                tStr = tStr & .ShowIconOnly
                tStr = tStr & SP
            Case xlUniqueValues             '8
                tStr = tStr & .DupeUnique
                tStr = tStr & .ScopeType
                tStr = tStr & SP
            Case xlTextString               '9
                tStr = tStr & .DateOperator
                tStr = tStr & .Formula1
                tStr = tStr & .Formula2
                tStr = tStr & .Operator
                tStr = tStr & .ScopeType
                tStr = tStr & .Text
                tStr = tStr & .TextOperator
                tStr = tStr & SP
            Case xlAboveAverageCondition    '12
                tStr = tStr & .AboveBelow
                tStr = tStr & .CalcFor
                tStr = tStr & .Formula1
                tStr = tStr & .Formula2
                tStr = tStr & .NumStdDev
                tStr = tStr & SP
            Case xlExpression, _
                 xlBlanksCondition, _
                 xlTimePeriod, _
                 xlNoBlanksCondition, _
                 xlErrorsCondition, _
                 xlNoErrorsCondition
                    tStr = tStr & .Formula1
                    tStr = tStr & .Formula2
                    tStr = tStr & SP
        End Select
        If InStr(1, fcType(fcT), tStr, vbBinaryCompare) = 0 Then
            fcType(fcT) = fcType(fcT) & tStr
        Else
            .Delete
            dupes = dupes + 1
        End If
    End With
End Sub

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'It returns the last cell of range with data, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange

    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                   After:=.Cells(1, 1), _
                                   SearchDirection:=xlPrevious, _
                                   SearchOrder:=xlByRows)
            Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                   After:=.Cells(1, 1), _
                                   SearchDirection:=xlPrevious, _
                                   SearchOrder:=xlByColumns)
            Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
        End With
    End If
End Function

A way to see all properties for a specific format condition:

enter image description here

Upvotes: 0

paul bica
paul bica

Reputation: 10715

This removes duplicate sets of conditional formatting rules created when copying and pasting rows:

Option Explicit

Public Sub resetConditionalFormatting()

    Const F_ROW As Long = 2
    Dim ws As Worksheet, ur As Range, maxCol As Long, maxRow As Long, thisCol As Long
    Dim colRng As Range, fcCol As Range, fcCount As Long, fcAdr As String

    Set ws = ThisWorkbook.ActiveSheet
    Set ur = ws.UsedRange
    maxRow = ur.Rows.Count
    maxCol = ur.Columns.Count

    Application.ScreenUpdating = False
    For Each colRng In ws.Columns
        If colRng.Column > maxCol Then Exit For
        thisCol = thisCol + 1
        Set fcCol = ws.Range(ws.Cells(F_ROW, thisCol), ws.Cells(maxRow, thisCol))
        With colRng.FormatConditions
            If .Count > 0 Then
                fcCount = 1
                fcAdr = .Item(fcCount).AppliesTo.Address

                While fcCount <= .Count
                    If .Item(fcCount).AppliesTo.Address = fcAdr Then
                        .Item(fcCount).ModifyAppliesToRange fcCol
                        fcCount = fcCount + 1
                    Else
                        .Item(fcCount).Delete
                    End If
                Wend

            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub

.

At high level:

  • It goes through each column of the used range of the active sheet
  • Determines duplicates based on sets of addresses

  • If it finds multiple sets:

    • For the first set - it updates the AppliesTo range to (firstRow:lastRow)
    • Deletes all other sets

(a duplicate counter can be added after the .Delete statement)

Test file

Initial rules:

Initial rules

After copying and pasting the last 2 rows, twice:

After copying and pasting the last 2 rows twice

After cleanup:

enter image description here

Notes:

  • There are 14 different types of rules and many properties are different
  • Not all types have .Formula or .Formula1, or even the same formatting properties
  • Types can be seen in the test file or this Microsoft page

Upvotes: 2

Related Questions