excel - 搜索特定单词并删除所有不包含完全匹配的行

Question

我有一个 3000 行的 Excel 表。目标是我在 Inputbox 中输入要搜索的列和另一个词 Inputbox ，VBA 宏会删除所有不满足条件的行。
有人帮助我把它放在一起，但结果不是 100% 预期的。如果我插入 Inputbox这个词，我需要像我插入的结果，而不是单数或复数的词。
我需要类似搜索功能“匹配整个单元格内容”的内容。此选项在下面的代码中不可用。

Sub DelRows()    Application.ScreenUpdating = False
    Dim a, b, nc As Long, i As Long, Col As String, response As String
    Col = InputBox("Enter the column letter:")
    response = InputBox("Enter the taxonomy:")
    nc = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    a = Range(Col & "1", Range(Col & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If Not a(i, 1) Like "*" & response & "*" Then b(i, 1) = 1
    Next i
    With Range(Col & "1").Resize(UBound(a), nc)
      .Columns(nc).Value = b
    '  .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
    '        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
      On Error Resume Next
      .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
      On Error GoTo 0
    End With
    Application.ScreenUpdating = True
End Sub

假设您有如下数据:

row 1: Tree
row 2: Trees
row 3: Trees; leaf
row 4: Tree; leaf

我想在上面的脚本中:
一个 Inputbox必须搜索哪一列。 (已经写好了)
一个 Inputbox用于搜索的单词(已经写好了，但 树 和 树 显示)
Excel 工作表的第一行不得删除
所有不满足输入框条件的行都被删除
在上面的示例中(显示完全匹配的“树”)，结果应该是:

row 1: Tree
row 4: Tree; leaf

我读过“查找功能”有一个“匹配整个单元格内容”选项。
如何转换已经编写的内容并与新的编码合并？

单词总是以大写字母开头(例如 Tree)

这个词可以是一个独立的词(例如树)

在单词的末尾(两个单词之间)， ;-符号和空格 可用(例如，树；叶子)(仅在多个单词的情况下)

在单词的开头(两个单词之间)， ;-符号和空格 可用(例如，叶子；树)或(叶子；树；页面)(仅在多个单词的情况下)

Answer 1

根据单元格子字符串删除行

将完整代码复制到标准模块中(例如 Module1 )。

调整常量 Ant 包括worksheet如有必要。

只运行 第一个子 ，其余的被调用。

代码

Option Explicit

Sub DelRows()
    
    Const LastRowColumn As Variant = "A"
    Const FirstRow As Long = 1
    Const ignoreCase As Boolean = False
    Dim Suffixes As Variant: Suffixes = Array(";")
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim rng As Range, Response As Variant, Col As Variant
    
    MyInputBox ws, rng, Response, Col

    Set rng = Columns(LastRowColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then GoTo LastRowColumnWrong
    If rng.Row < FirstRow Then GoTo FirstRowWrong
    Set rng = ws.Range(ws.Cells(FirstRow, ws.Columns(Col).Column), _
                       ws.Cells(rng.Row, ws.Columns(Col).Column))
       
    Dim Data As Variant: Data = rng: Set rng = Nothing
    Dim Coll As New Collection, Current As Variant, CurrVal As Variant
    Dim CollOff As Long: CollOff = FirstRow - 1
    Dim ResponseSuff As String
    Dim iCase As Long: iCase = Abs(ignoreCase)
    Dim UBS As Long: UBS = UBound(Suffixes)
    Dim i As Long, j As Long, l As Long
    For i = 1 To UBound(Data)
        If VarType(Data(i, 1)) <> vbString Then
            collectIndexes Coll, i + CollOff ' Is not a string.
        Else
            CurrVal = Data(i, 1)
            If InStr(1, CurrVal, Response, iCase) = 0 Then
                collectIndexes Coll, i + CollOff ' Not found in CurrVal.
            Else
                Current = Split(CurrVal, " ")
                If Not existsString(Current, Response, iCase) Then
                    For l = 0 To UBS
                        ResponseSuff = Response & Suffixes(l)
                        If existsString(Current, ResponseSuff, iCase) Then
                            Exit For
                        End If
                    Next l
                    ' Check if not found in any suffix combination.
                    If l > UBS Then collectIndexes Coll, i + CollOff
                End If
            End If
         End If
    Next i
    
    If Coll.Count = 0 Then GoTo AllRows
    
    collectRows ws, rng, Coll
    
    If Not rng Is Nothing Then
        rng.EntireRow.Hidden = True ' Test with Hidden first.
        'rng.EntireRow.delete
    End If
    
    Exit Sub

LastRowColumnWrong:
    MsgBox "No data in column '" & LastRowColumn & "'.", vbExclamation, _
           "Wrong Last Row Column (Empty)"
    Exit Sub
    
FirstRowWrong:
    MsgBox "First row '" & FirstRow & "' is below last row '" & rng.Row _
           & "'.", vbExclamation, _
           "Wrong First Row"
    Exit Sub

AllRows:
    MsgBox "All rows in column '" & Col & "' contain '" & Response & "'.", _
      vbInformation, "All Rows"
    Exit Sub

End Sub

Function existsString(Data As Variant, _
                      ByVal eString As String, _
                      Optional ByVal ignoreCase As Boolean = False) _
         As Boolean
    Dim i As Long, iCase As Long: iCase = Abs(ignoreCase)
    For i = 0 To UBound(Data)
        If StrComp(Data(i), eString, iCase) = 0 Then
            existsString = True: Exit Function
        End If
    Next
End Function

Sub collectIndexes(ByRef Coll As Collection, ByVal IndexNumber As Long)
    Coll.Add IndexNumber
End Sub

Sub collectRows(WorksheetObject As Worksheet, _
                ByRef rng As Range, _
                Coll As Collection)
    Dim i As Long
    For i = 1 To Coll.Count
        If Not rng Is Nothing Then
            Set rng = Union(rng, WorksheetObject.Rows(Coll(i)))
        Else
            Set rng = WorksheetObject.Rows(Coll(1))
        End If
    Next i

End Sub

Sub MyInputBox(WorksheetObject As Worksheet, _
                   ByRef rng As Range, _
                   ByRef Response As Variant, _
                   ByRef Col As Variant)
    
    Dim Continue As Variant

InputCol:
    Col = Application.InputBox( _
      Prompt:="Enter the column letter(s) or column number:", Type:=1 + 2)
    GoSub ColNoEntry
    GoSub ColWrongEntry
    
InputResponse:
    Response = Application.InputBox("Enter the taxonomy:", Type:=2)
    GoSub ResponseNoEntry

    Exit Sub
    
ColNoEntry:
    If Col = False Then Exit Sub
    If Col = "" Then
        Continue = MsgBox("Try again?", vbOKCancel, "No Entry")
        If Continue = vbOK Then GoTo InputCol Else Exit Sub
    End If
    Return

ColWrongEntry:
    On Error Resume Next
    Set rng = WorksheetObject.Columns(Col)
    If Err.Number <> 0 Then
        Continue = MsgBox("Try again?", vbOKCancel, "Wrong Entry")
        If Continue = vbOK Then
            On Error GoTo 0
            GoTo InputCol
        Else
            Exit Sub
        End If
    Else
        On Error GoTo 0
    End If
    Return

ResponseNoEntry:
    If Response = False Then Exit Sub
    If Response = "" Then
        Continue = MsgBox("Try again?", vbOKCancel, "No Entry")
        If Continue = vbOK Then GoTo InputResponse Else Exit Sub
    End If
    Return
    
End Sub