如果一个单元格不是红色或蓝色，则删除整行-Deleteentirerowifnotevenonecellisredorblue

My macro is provided below. I want to delete all the rows, in which not even one cell is blue or red! So, the macro performs some coloring in the beginning, which works great! But, when I want to just keep the rows that have the colored cells, it does not work correctly. The macro does not tell me that it has an error. It just runs but never stops running :p Any ideas? Much appreciated!

我的宏在下面提供。我想删除所有行，其中甚至一个单元格都不是蓝色或红色！所以，宏在开始时执行一些着色，效果很好！但是，当我想保留具有彩色单元格的行时，它无法正常工作。宏没有告诉我它有错误。它只是运行但从未停止运行：p任何想法？非常感激！

Sub PO()

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Worksheets("Tracker").Cells.Copy
    With Worksheets("po")
    .Cells.PasteSpecial xlValues
    .Cells.PasteSpecial xlFormats
    End With

    Sheets("po").Select

    Dim mDiff1 As Double
    mDiff1 = 0.01
    Dim mDiff2 As Double
    mDiff2 = 0.03
    Dim mDiff3 As Double
    mDiff3 = 0.01
    Dim mDiff4 As Double
    mDiff4 = 0.03

    For Each cell1 In Range(Range("U2"), Range("U2").End(xlDown))
    If cell1.Value - cell1.Offset(0, 1).Value > mDiff1 Then
    cell1.Offset(0, 1).Interior.ColorIndex = 3
    End If
    If cell1.Value - cell1.Offset(0, 2).Value > mDiff2 Then
    cell1.Offset(0, 2).Interior.ColorIndex = 5
    End If
    Next cell1

    For Each cell2 In Range(Range("AB2"), Range("AB2").End(xlDown))
    If cell2.Value - cell2.Offset(0, 1).Value > mDiff3 Then
    cell2.Offset(0, 1).Interior.ColorIndex = 3
    End If
    If cell2.Value - cell2.Offset(0, 2).Value > mDiff4 Then
    cell2.Offset(0, 2).Interior.ColorIndex = 5
    End If
    Next cell2

    Dim row As Range
    Dim cell3 As Range

    For Each row In Range("A2", Range("A2").End(xlDown).End(xlToRight)).Rows
    For Each cell3 In row.Cells
    If Not cell3.Interior.ColorIndex = 3 Or cell3.Interior.ColorIndex = 5 Then
    cell3.EntireRow.Delete
    End If
    Next cell3
    Next row

    Sheets("po").Select
    If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Rows(1).AutoFilter
    End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

1 个解决方案

Dim i As Long, lr As Long, nodel As Boolean
Dim mDiff1 As Double, mDiff2 As Double, mDiff3 As Double, mDiff4 As Double

mDiff1 = 0.01
mDiff2 = 0.03
mDiff3 = 0.01
mDiff4 = 0.03

With Worksheets("po")
    lr = Application.Max(.Cells(.Rows.Count, "U").End(xlUp).Row, _
                         .Cells(.Rows.Count, "AB").End(xlUp).Row)
    For i = lr To 2 Step -1
        nodel = False
        If .Cells(i, "U").Value2 - .Cells(i, "U").Offset(0, 1).Value2 > mDiff1 Then
            .Cells(i, "U").Offset(0, 1).Interior.ColorIndex = 3
            nodel = True
        End If
        If .Cells(i, "U").Value2 - .Cells(i, "U").Offset(0, 2).Value2 > mDiff2 Then
            .Cells(i, "U").Offset(0, 2).Interior.ColorIndex = 5
            nodel = True
        End If
        If .Cells(i, "AB").Value2 - .Cells(i, "AB").Offset(0, 1).Value2 > mDiff3 Then
            .Cells(i, "AB").Offset(0, 1).Interior.ColorIndex = 3
            nodel = True
        End If
        If .Cells(i, "AB").Value2 - .Cells(i, "AB").Offset(0, 2).Value2 > mDiff4 Then
            .Cells(i, "AB").Offset(0, 2).Interior.ColorIndex = 5
            nodel = True
        End If
        If Not nodel Then
           .Rows(i).EntireRow.Delete
        End If
    Next i
End With