Excel VBA宏，用于在列与某些单词匹配时删除行

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。尝试：

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