清除条件格式（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并列）的机会。

如果没有人想要或者知道如何实现，那么也许一些提示？？？来吧，帮帮我！

- anəˈnimədē

---

听起来你想做的是删除重复项并计算数量。条件格式化与此有什么关系？只需定义您的范围（SO上有很多帖子可以告诉您如何做到这一点）；计算该范围内的条目数；执行range.removeduplicates方法，然后再次计数。在消息框中报告差异。如果您不想留下唯一项，则可能会有所不同，但从您的帖子中并不清楚。 - Ron Rosenfeld

从宏录制器开始，修改和删除一些条件格式，并使用生成的代码作为起点。然后编辑您的帖子以包含该代码。 - ChipsLetten

ChipsLetten：感谢您的回复，也非常感谢您理解我的帖子！我希望有人已经设计出这个工具并可以直接给我。虽然我不介意从头开始，但在开始之前询问一下是否已经有人“发明了轮子”也无妨。 - anəˈnimədē

我真的很惊讶，为什么这不是大多数人个人宏工具箱中的常规功能。每当我的同事们忽略“仅粘贴数值”规则时，我都非常讨厌不得不删除数十个重复的条件格式项。难道只有我这样吗？其他人喜欢这样做吗？ - anəˈnimədē

我也不喜欢清理它们；一个小工具可能会很有用。我会开始研究一下。 - paul bica

我不知道你长什么样，Paul，但我打赌你的帽子上有一个光环！ - anəˈnimədē

Answer 1

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

以下是代码：

'''
' MergeConditionalFormatting - Add-in to merge conditional formatting.
' Author: Christopher Rath <[e-mail]>
' 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

- Christopher Rath

Answer 2

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

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

.

在高层次上:

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

• 如果找到多个集合:

  • 对于第一个集合 - 更新AppliesTo范围为（firstRow:lastRow）
  • 删除所有其他集合

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

---

测试文件

初始规则：

在复制并粘贴最后两行两次后：

清理后：

---

注意：

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

- paul bica

---

保罗，这太棒了。你太厉害了。我会开始使用它，并告诉你如果遇到代码无法处理的情况。 - anəˈnimədē

我很高兴你喜欢它，但它并不符合你最初的要求。这只是自动化基本任务的初始尝试，即删除重复项，假设每列只应定义一个单一规则 - 如果为同一列定义了多个规则，则会删除除第一个以外的所有规则，因此仅适用于简单的文件。为使其尽可能通用，查找重复项的标准变得非常复杂，因为有14种类型的规则，它们没有相同的属性，如Formula1、格式等。 - paul bica

很高兴你如此坚持不懈 :) 我会在之前的尝试中给出一个提示，因为复杂性而放弃 - 我会将代码放在一个新答案中。 - paul bica

仍然是一个很好的开始！我比我知道的更有资源，所以这对我来说非常完美。我认为您的列方法也可以用于行，进行二维评估。此外，如果我让For Each评估记住数组中的数据而不是删除，那么我可以简化数组，删除所有条件，并将数组解码回条件。这听起来像是一个“耳塞在耳朵里，每个人都出去”的项目，但我很兴奋！（我觉得我在上次评论中看到了一个错别字，然后超过了我需要修订它的五分钟时间） - anəˈnimədē

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

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

- paul bica

---

没错! 绝对是一个耳塞项目。再次感谢保罗! 我可以看出你的方法比我以前使用过的更先进，所以我还有一些学习要做! 你放弃这种方法的原因是什么？只是因为14种条件格式类型彼此非常不同，标准化的过程就会产生错误吗？ - anəˈnimədē

有几个原因：1. 我让你等待了太久的答案；2. 对于每一列中条件格式相同的任务，适当的（通用）解决方案变得过于复杂 - 你接受的答案对此很有效，并且相当简单（我也可以在某些文件中使用它）。更通用的解决方案需要更多的努力，即使对于复杂的条件格式，它可能仍然无法正常工作；最好手动清理，但也许你会找到一个安全的方法来做 :) - paul bica

#1: 很奇妙/棒，像你这样的人还存在，感谢你对陌生人的体贴！我敢打赌你在高速公路并线时也会使用转向灯。 #2: 我一定会找到办法！你知识的火柴已经点燃了我不可改变性格的森林；而后果是不可阻挡的！（现在开森林大火的笑话太早了吗？） - anəˈnimədē

当 fc 不连续时，情况会变得更加复杂，例如：A1 单元格的 fc 为粗体和斜体，A2 的 fc 为标准字体、黄色背景，A3 的 fc 为粗体和斜体。现在你必须跟踪重复的 A1、A3 等 fc 的范围。如果这不清楚或需要更多细节，请告诉我，我们可以聊一聊。 - paul bica

嗯，糟糕了。这似乎比治愈癌症更加复杂。我希望我没有工作，这样我就可以“只是”专注于这个事情。（然而，我是为我的工作在做这个，那时就像是“《玛吉的礼物》”一样了。） - anəˈnimədē