删除Excel个格式条件

Delete Excel individual format condition

我有一本带有条件格式的旧工作簿,在随机条件格式演变方面已经失控。我想遍历 sheet 并删除所有仅引用一个单元格的条件格式(但在同一单元格中保留其他格式,当然还保留单元格值等)

我将代码写在一个单独的 sheet 中,以便 (1) 我可以重复使用它 (2) 工作簿本身不需要宏

到目前为止,我可以识别单元格,但不能删除格式。我的代码是:

Option Explicit

Sub Delete_Conditional()

Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook

    Set wb = Workbooks("Book1.xlsx")
    Set ws = wb.Worksheets("Sheet1")
    
    'Find last cell and set a range to cover all cells
    lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
    
    'Loop through all cells
    For Each rCell In rAllCells.Cells
        'Loop through all FormatConditions in the cell
        For Each fc In rCell.FormatConditions
            'Determine if the FormatCondition only applies to one cell
            If fc.AppliesTo.Cells.Count = 1 Then
                Debug.Print fc.AppliesTo.Address
                'I have tried fc.Delete
                'I have tried fc.AppliesTo.Delete
                End If
            Next fc
        Next rCell

End Sub

当我返回 sheet 时,我可以看到格式仍然存在。

从项目集合中删除时,如果您向后工作,有时效果会更好:

Sub Delete_Conditional()

Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook, i As Long

    Set wb = Workbooks("Book1.xlsx")
    Set ws = wb.Worksheets("Sheet1")
    
    'Find last cell and set a range to cover all cells
    lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
    
    'Loop through all cells
    For Each rCell In rAllCells.Cells
        'Loop through all FormatConditions in the cell
        For i = rCell.FormatConditions.Count To 1 Step -1
            With rCell.FormatConditions(i)
                If .AppliesTo.Cells.Count = 1 Then
                    Debug.Print .AppliesTo.Address
                    .Delete
                End If
            End With
        Next i
    Next rCell

End Sub