Question

我有一个报告，其中“ E”列具有某些状态。我只需要一两个，就需要删除其余的。是否有一个宏可以搜索列“ E”并在匹配时从以下列表中删除？

DEAL_EXPIRED
DEAL_CLEARED
DEAL_AWAITING_AUTH
DEAL_AUTH_FAILED

Answer 1

假设您的数据在第一行具有标题，则可以使用以下代码：

Option Explicit

Sub DeleteMe()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim DeleteMe As Range, i As Long, ARR

ARR = ws.Range("E2:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Value

For i = LBound(ARR) To UBound(ARR)
    Select Case ARR(i, 1)
        Case "DEAL_EXPIRED", "DEAL_CLEARED", "DEAL_AWAITING_AUTH", "DEAL_AUTH_FAILED"
            If Not DeleteMe Is Nothing Then
                Set DeleteMe = Union(DeleteMe, ws.Range("E" & i + 1))
            Else
                Set DeleteMe = ws.Range("E" & i + 1)
            End If
    End Select
Next i

If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete

End Sub

Answer 2

对于此答案，我使用Sheet1.Try：

Option Explicit

Sub test()

    Dim LR As Long
    Dim i As Long

       With ThisWorkbook.Worksheets("Sheet1")

            LR = .Cells(.Rows.Count, "E").End(xlUp).Row

            For i = LR To 1 Step -1

                If .Range("E" & i).Value = "DEAL_EXPIRED" Or .Range("E" & i).Value = "DEAL_CLEARED" Or .Range("E" & i).Value = "DEAL_AWAITING_AUTH" Or .Range("E" & i).Value = "DEAL_AUTH_FAILED" Then
                    .Rows(i).EntireRow.Delete
                End If

            Next i

        End With

End Sub

Answer 3

显式选项

Private D1     As Variant
Private RSel   As Range
Private R2Del  As Range

Public Sub Squadra_Unita(Optional ByVal msg As Variant) _
    'https://youtu.be/sE6CMwO5Qm8

    Rows_Delete _
            Range_Walk( _
            List_Ask( _
            Selection_Check))
End Sub

Public Function Rows_Delete(Optional ByVal msg As Variant) _
       As Variant

    If R2Del Is Nothing Then _
       Exit Function

    R2Del.EntireRow.Delete shift:=xlUp

End Function

Public Function Range_Walk(Optional ByVal msg As Variant) _
       As Range
    Dim x      As Long
    For x = LBound(D1) To UBound(D1)
        Set R2Del = App_Union( _
                    R2Del, _
                    Search_Get(RSel, D1(x)))
    Next
End Function

Public Function Search_Get(ByVal r As Range, ByVal str As String) _
       As Variant

    Dim c As Range, found As Range, firstAddress As String

    With r
        Set c = .Find( _
                what:=str, LookAt:=xlPart, MatchCase:=False)

        If Not c Is Nothing Then
            firstAddress = c.Address
            Do

                Set found = App_Union(found, c)

                Set c = .FindNext(c)

                If c Is Nothing Then Exit Do

            Loop While c.Address <> firstAddress

        End If
    End With

    If Not found Is Nothing Then _
       Set Search_Get = found

End Function

Public Function List_Ask(Optional ByVal msg As Variant) As Variant        '   Òåñòîì ÍÅ ïîêðûòà
    Dim str    As String
    str = Application.InputBox( _
          "Type words with space", _
          "List for Delete Rows in Selection", , , , , , 2)

    D1 = Split(str)

End Function

Public Function Selection_Check(Optional ByVal msg As Variant) _
       As Variant

    If Selection.Count < 2 Then

        MsgBox "Need more selection :-)"

        End

    Else

        Set RSel = Application.Intersect( _
                   ActiveSheet.UsedRange, _
                   Selection)
    End If
End Function

Public Function App_Union(rng_Union As Range, _
                          ByVal rng As Range) _
                          As Range
' Set rng_union = App_Union(rng_union, .Rows(x))

    If Not rng_Union Is Nothing Then

        Set rng_Union = Application.Union(rng_Union, rng)

    Else

        Set rng_Union = rng

    End If

    Set App_Union = rng_Union

End Function

Excel VBA宏，如果某列与某些单词匹配则删除行

3 个答案: