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

Question

我有一张 3000 行的 Excel 表。 目标是我在 Inputbox 中输入要搜索的列，在另一个Inputbox中输入要搜索的单词， Inputbox宏会删除所有不符合条件的行。

有人帮助我把它放在一起，但结果不是 100% 预期的。 如果我在输入Inputbox插入单词，我需要像我插入的结果而不是单数或复数的单词。

我需要类似搜索 function“匹配整个单元格内容”的内容。 此选项在下面的代码中不可用。

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

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

1. 单词总是以大写字母开头（例如 Tree）
2. 这个词可以是一个独立的词（例如树）
3. 在单词的末尾（两个单词之间），有一个;-符号和一个空格可用（例如，树；叶子）（仅在多个单词的情况下）
4. 在单词的开头（两个单词之间），有一个;-符号和一个空格可用（例如，叶子；树）或（叶子；树；页）（仅在多个单词的情况下）

Answer 1

这是整个代码。 将其粘贴到标准代码模块。 我建议您在运行之前阅读其中的所有注释以及代码下方的所有解释和说明。

Option Explicit

Sub GetCriteria()
    ' 062 01 Jul 2020
    
    Const DelRows   As Boolean = True   ' False to keep rows hidden
    
    Dim Ws          As Worksheet        ' the worksheet to work on
    Dim Clm         As Variant          ' target column
    Dim SearchWord  As String           ' word to search for
    Dim Spike       As Variant          ' list of rows for deletion
    Dim DelRng      As Range            ' range of rows to delete
    Dim i           As Long             ' loop counter: index of Spike
    
    Do
        ' "Toxin" is the default here: Change to suit (most commonly used)
        SearchWord = InputBox("Enter the key word to search for." & vbCr & _
                              "(not case sensitive)", _
                              "Toxonomy", "Toxin")
        If SearchWord = "" Then Exit Sub                ' user cancelled
        
        ' at this point the validity of the entry could be checked
    Loop While SearchWord = ""
    
    ' it's likely that there is a relation ship between the SearchWord
    ' and the column to seach in. Therefore the next input could
    ' probably be avoided by employing a lookup table.

    Do
        ' "A" is the default here: change to suit
        Clm = InputBox("Specify the column to search." & vbCr & _
                       "(Enter a column name or number)", _
                       "Target column", "A")
        If Clm = "" Then Exit Sub                       ' user cancelled
        
        If Not IsNumeric(Clm) Then
            On Error Resume Next
            Clm = Columns(Clm).Column
        End If
        ' define the smallest and largest permissible column number
        ' the number can't be smaller than 1 and (10 = column J)
        If (Clm > 0) And (Clm < 10) Then Exit Do
        MsgBox "Column doesn't exist." & vbCr & _
               "Please try again.", vbInformation, "Invalid entry"
    Loop
    
    ' change the name of the specified worksheet
    Set Ws = ThisWorkbook.Worksheets("Toxonomy")
    
    Application.ScreenUpdating = False
    Ws.Rows.Hidden = False
    Spike = FilterData(Clm, SearchWord, Ws)
    
    For i = 1 To UBound(Spike)
        If Not Spike(i) Then
            If DelRng Is Nothing Then
                Set DelRng = Ws.Rows(i)
            Else
                Set DelRng = Application.Union(DelRng, Ws.Rows(i))
            End If
        End If
    Next i

    If DelRows Then
        DelRng.Delete
    Else
        DelRng.Rows.Hidden = True
    End If
    Application.ScreenUpdating = True
End Sub

Private Function FilterData(ByVal Clm As Long, _
                            ByVal SearchWord As String, _
                            Ws As Worksheet) As Variant
    ' 062 01 Jul 2020
    ' return a list of rows for deletion

    Const FirstDataRow  As Long = 2             ' specify the first row with data
    
    Dim Fun             As Variant              ' prepare function return value
    Dim Rng             As Range                ' the range (in Clm) to search in
    Dim Rl              As Long                 ' last used row in Ws
    Dim Fnd             As Range                ' a matching cell
    Dim FirstFound      As Long                 ' row where the first match was found
    
    With Ws
        ' from the specified first row to the last used row in Clm
        Rl = .Cells(.Rows.Count, Clm).End(xlUp).Row
        Set Rng = .Range(.Cells(FirstDataRow, Clm), .Cells(Rl, Clm))
    End With
    ReDim Fun(1 To Rl)
    For Rl = 1 To (FirstDataRow - 1)
        Fun(Rl) = True                          ' exclude from deletion
    Next Rl
    
    Set Fnd = Rng.Find(SearchWord, Rng.Cells(1), _
                       LookIn:=xlValues, LookAt:=xlPart, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False)
    If Not Fnd Is Nothing Then
        FirstFound = Fnd.Row
        Do
            If CandidateIsQualified(SearchWord, Fnd.Value) Then
                Fun(Fnd.Row) = True             ' exclude from deletion
            End If
            
            Set Fnd = Rng.FindPrevious(Fnd)
            If Fnd Is Nothing Then Exit Do
        Loop While Fnd.Row < FirstFound
    End If
    
    FilterData = Fun
End Function

Private Function CandidateIsQualified(ByVal SearchWord, _
                                      ByVal Cand As String) As Boolean
    ' 062
    ' return True if the Candidate matches the Searchword

    Const Separators As String = " ,;./"  ' characters that might separate
                                        ' Searchword within Candidate string
                                        ' add or reduce as needed
    Const MatchCase As Boolean = True   ' modify to suit
    
    Dim Fun         As Boolean          ' function return value
    Dim Mc          As VbCompareMethod  ' conversion of MatchCase
    Dim Sp()        As String           ' helper to examine Candidate
    Dim f           As Integer          ' loop counter: split characters (Separators)
    Dim i           As Integer          ' loop counter: index of Sp()
    
    Mc = IIf(MatchCase, vbBinaryCompare, vbTextCompare)
    If StrComp(Cand, SearchWord, Mc) Then
        For f = 1 To Len(Separators)
            Sp = Split(Cand, Mid(Separators, f, 1))
            For i = 0 To UBound(Sp)
                If StrComp(SearchWord, Trim(Sp(i)), Mc) = 0 Then
                    Fun = True
                    Exit For
                End If
            Next i
            If Fun Then Exit For
        Next f
    Else
        Fun = True
    End If
    
    CandidateIsQualified = Fun
End Function

Sub GetCriteria命名错误，因为获取搜索条件只是它的工作之一。 它兼作Main ，这意味着这是您为完成整个工作而运行的过程。 项目中的其他两个程序适用于此。 他们都需要知道他们应该在哪个工作表上工作。 这在此行中指定Set Ws = ThisWorkbook.Worksheets("Toxonomy") 。 将名称更改为工作簿中存在的名称。 ThisWorkbook指定工作表必须与代码位于同一工作簿中。 那是没有必要的。 您可以在此处指定另一个工作簿。 但是请避免使用ActiveWorkbook ，因为当您运行删除数据的代码时，您会后悔。

寻找Const DelRows 。 它设置为真。 这会导致已识别的行被删除。 我不喜欢删除数据。 因此我的程序允许你另一种选择。 如果您设置 Const DelRows = False，您将获得相同的视觉结果，但行只是被隐藏，因此可以被检索。

在编辑提示时查看两个 InputBox 的两个默认值。 在其中任何一个中输入任何内容都会终止程序。 列号设置了限制，代码旨在让您轻松检查搜索词以确保其有效。 我们在这里谈论数据删除。 所以最好避免错误，包括拼写错误。

Function FilterData使用Find function 来查找匹配项。 它需要知道在哪里寻找。 将Const FirstDataRow设置为正确的值。 宏将自行确定最后一行，从 InputBox 中获取列，并包括搜索中使用的第一行和最后一行之间的所有行。 并非所有包含您要查找的词的行都符合保留条件。 为了便于维护，我已将测试放在单独的程序中。

Function CandidateIsQualified将返回 True 或 False。 您关于什么被认为是真或假的规则是不完整的，但是这个 function 允许扩展。 查找Const Separators我列出了 6 个 (",;./") 包括一个空格。 function 将尝试 SearchWord 是否受其中任何一个限制。 您可以添加到列表中。 不要添加逗号或空格，因为此字符串中的字符越多，代码运行的速度就越慢。 因此删除可能永远不会发生的选项。

注意Const MatchCase 。 它当前设置为True ，这意味着如果 SearchWord 是“树”，则不会找到“树”。 您可以通过设置 MatchCase = False 来改变这种态度。

如果 Function CandidateIsQualified 返回True Function FilterData 将标记此类数字列表中的行，然后将其返回给 Sub GetCriteria，如果 Const DelRows 这么说，列表中未找到的行将被删除或隐藏。

Answer 2

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

• 将完整的代码复制到标准模块（例如Module1 ）中。
• 如有必要，调整包括worksheet在内的常量。
• 仅运行第一个 Sub ，正在调用 rest。

编码

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