干净的条件格式（Excel VBA）

Question

如果这个问题已经得到解答，但我找不到，我深表歉意。这就是我想要的：我们都知道删除范围、行和列会拆分条件格式并使其变得可怕。我想创建一个个人宏：

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

我有 50% 的信心自己可以做到这一点，但我觉得我需要学习如何使用数组变量。 （对此我完全一无所知，因此感到害怕）所以如果有人已经创造了这个，那么我求你分享你的天才。或者，如果有人认为他们可以解决这个问题，我可以为您提供机会，让您有机会创建一个可能成为个人宏用户群中最常用的工具之一（如果不是）（就在 Ctrl 上方） +Shift+V)。

或者如果没有人有或想要，那么也许有一些提示？？？来吧，给我扔一根骨头！

Answer 1

这将删除复制和粘贴行时创建的重复的条件格式规则集：

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

.

高层：

• 遍历活动工作表已用范围的每一列
• 根据地址集确定重复项

• 如果找到多个集合：

  • 对于第一组 - 它会将 ApplysTo 范围更新为 (firstRow:lastRow)
  • 删除所有其他集

（可以在.Delete语句后添加重复计数器）

---

测试文件

初始规则：

复制并粘贴最后 2 行后，两次：

清理后：

---

注意事项：

• 有 14 种不同类型的规则，许多属性不同
• 并非所有类型都具有 .Formula 或 .Formula1，甚至具有相同的格式属性
• 可以在测试文件中查看类型或this Microsoft page

Answer 2

这是我对这个问题的回答。我只为使用公式的条件格式实现了它，因为我很少使用其他条件格式类型。它也可以作为我个人网站的插件使用：MergeConditionalFormatting v1.2

代码如下：

'''
' MergeConditionalFormatting - Add-in to merge conditional formatting.
' Author: Christopher Rath <christopher@rath.ca>
' 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://docs.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

Answer 3

这是一个不完整的尝试，使其尽可能通用（仅作为起点提供）

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

查看特定格式条件的所有属性的方法：