Question

下面是我正在使用的当前（不完整）代码，它可以正常删除任何给定的行，但我真正需要做的是识别符合特定条件的行：
列L中的单元值＆gt; 90％
OR
列M中的单元值＆gt; 90％

然后，如果其中任何一个为真，我需要在同一行G列中找到Cell Value并删除G列中包含相同值的所有行。

   Sub sbDelete_Rows_Based_On_Multiple_Criteria()
    Dim lRow As Long
    Dim iCntr As Long
    lRow = Cells(Rows.Count, "G").End(xlUp).Row
    For iCntr = lRow To 2 Step -1
        If Cells(iCntr, "L") > 0.90 OR Cells(iCntr, "M") > 0.90 Then
            Cells(iCntr, "G").EntireRow.Delete
        End If
    Next iCntr
  End Sub

-

我希望在我的示例中完成的任务将导致唯一未被删除的Serial＃1910910

提前感谢您的帮助。

Answer 1

这应该有效：

Sub sbDelete_Rows_Based_On_Multiple_Criteria()
Dim lRow As Long
    lRow = findLastRow()
For iCNTR = lRow To 2 Step -1
    If evaluateIfOver90Percent(iCNTR) Then
        If Cells(iCNTR, "E") = 1 Then
            Cells(iCNTR, "A").EntireRow.Delete
        Else
            Dim SerialNumToDelete As Double
                SerialNumToDelete = Cells(iCNTR, "A")
            Dim NewLastRow
                NewLastRow = findLastRow()
                For rownum = NewLastRow To 2 Step -1
                    If evaluateIfSerialNumberIsADuplicate(rownum, SerialNumToDelete) Then
                        Cells(rownum, "A").EntireRow.Delete
                        iCNTR = iCNTR - 1
                    End If
                Next rownum
                iCNTR = iCNTR + 1
        End If
    End If
Next iCNTR
End Sub

Function findLastRow()
    findLastRow = Cells(Rows.Count, "A").End(xlUp).Row
End Function

Function evaluateIfOver90Percent(ByVal iCNTR As Integer)
    If Cells(iCNTR, "B") > 0.9 Or Cells(iCNTR, "C") > 0.9 Then
        evaluateIfOver90Percent = True
    Else
        evaluateIfOver90Percent = False
    End If
End Function

Function evaluateIfSerialNumberIsADuplicate(ByVal rownum As Integer, ByVal   SerialNumToDelete As Double)
    If Cells(rownum, "A") = SerialNumToDelete Then
        evaluateIfSerialNumberIsADuplicate = True
    Else
        evaluateIfSerialNumberIsADuplicate = False
    End If
End Function

Answer 2

Sub ToDelete()

    Dim last_row&

    '// NOTE! The code assumes that range:
    '// 1) starts in column A
    '// 2) ends in column O
    last_row = Cells(Rows.Count, "G").End(xlUp).Row
    '// Helper column 1
    With Range("P2:P" & last_row)
        .Formula = "=IF(OR(M2>0.9,L2>0.9),1,0)"
        .Value = .Value 'Overwrite formula
    End With
    '// Helper column 2
    With Range("Q2:Q" & last_row)
        .Formula = "=IF(SUMIF(G:G,G2,P:P)>0,1,0)"
        .Value = .Value 'Overwrite formula
    End With

    Rows(1).CurrentRegion.AutoFilter Field:=17, Criteria1:=1
    Rows("2:" & last_row).EntireRow.Delete
    ActiveSheet.AutoFilterMode = False 'Remove filter
    Columns("P:Q").Delete 'Remove helper columns

End Sub

Answer 3

当满足条件时，您可以使用数组存储G列中的值！像这样：

Sub DeleteValues()

Dim myArray() As Variant
Dim x as long, y as long

'Loop through all rows
For x = 2 to ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    If Range("L" & x).value > 0.9 or Range("M" & x).value > 0.9 then
        ReDim Preserve myArray(y)
        myArray(y) = Range("G" & x).value        
        y = y + 1
    End if
Next x

'Delete all rows that contain a value that occurs in your array
For x = LBound(myArray) To UBound(myArray)
StartOver:  With Worksheets(1).Range("G2:G" & ActiveSheet.Range("A" &     Rows.Count).End(xlUp).Row)
        Set c = .Find(myArray(x), lookin:=xlValues)
        If Not c Is Nothing Then
            Rows(c.row).entirerow.delete                
            goto StartOver
        End If
    End With
Next x

End sub

即使只有一行符合定义的条件，如何删除多个条目的所有行

3 个答案: