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

Question

I have an Excel sheet with 3000 rows. Target is that I input a column to search in an Inputbox and a word in another Inputbox , the VBA macro removes all the rows which do not fulfill the criteria.

Somebody assisted me to put this together, but the result isn't 100% expected. If I insert in the Inputbox the word, I need the results like I inserted and not the words in singular, or plural.

I need something like in the search function "match entire cell contents". This option is unusable in the code below.

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

Imagine you have data as below:

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

I want like in script above:
An Inputbox for which column has to be searched. (already written)
An Inputbox for the word to search for (already written but Tree and Trees are shown)
The first row of the Excel sheet must not be deleted
All the rows not fulfilling the criteria of inputbox to be deleted

On the example above (show the exact match "Tree"), the result should be:

row 1: Tree
row 4: Tree; leaf

I have read that the "find-function" has a "Match entire cell contents" option.
How do I transform the already written content and merge with the new coding?

1. The word is always starting with a capital letter (eg Tree)
2. The word can be a standalone word (eg Tree)
3. At the end of the word (between 2 words), a ;-sign and a space is available (eg, Tree; Leaf) (ONLY in case of multiple words)
4. At the beginning of the word (between 2 words), a ;-sign and a space is available (eg, Leaf; Tree) or (Leaf; Tree; Page) (ONLY in case of multiple words)

Answer 1

Here is the entire code. Paste it to a standard code module. I suggest you read all the comments in it and all the explanations and instructions below the code here before you run it.

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 is misnamed because getting the search criteria is only one of its jobs. It doubles as the Main , meaning this is the procedure you run in order to finish the entire job. The other two procedures in the project work for it. They all need to know which worksheet they are supposed to work on. This is specified in this line Set Ws = ThisWorkbook.Worksheets("Toxonomy") . Change the name to one that exists in your workbook. ThisWorkbook specifies that the worksheet must be in the same workbook as the code. That isn't necessary. You could specify another workbook right here. But avoid ActiveWorkbook because you will live to regret it while you run code that deletes data.

Look for the Const DelRows . It's set to True. That causes the identified rows to be deleted. I'm not a fan of deleting data. Therefore my program allows you another choice. If you set Const DelRows = False you get the same visual result but the rows are just hidden and can therefore be retrieved.

Look at the two default values for the two InputBoxes while you edit their prompts. Entering nothing in either of them terminates the program. There is a limit set on the column number and the code is designed to easily allow you to check the search term to make sure that it's valid. We are talking about data deletion here. So it's desirable to avoid mistakes, including typos.

Function FilterData uses the Find function to find matches. It needs to know where to look. Set the Const FirstDataRow to the correct value. The macro will determine the last row by itself, taking the column from the InputBox, and include all rows between the first and the last used in the search. Not all rows that include the word you are looking for are eligible for retention. I have placed the test in a separate procedure for maintenance convenience.

Function CandidateIsQualified will return True or False. Your rules for what is to be considered True or not are incomplete but this function allows for extension. Look for the Const Separators I have made a list of 6 (",;./") including a space. The function will try out if the SearchWord is bounded by any of them. You can add to the list. Don't add commas or spaces because the more characters you have in this string the slower the code will run. Therefore remove options which may never occur.

Pay attention to the Const MatchCase . It's currently set to True , meaning "Tree" will not be found if the SearchWord is "tree". You can change that attitude by setting MatchCase = False.

If Function CandidateIsQualified returns True Function FilterData will mark the row in a list of such numbers which it returns to Sub GetCriteria where the rows not found in the list will be either deleted, if the Const DelRows says so, or hidden.

Answer 2

Delete Rows Based on Cell Sub String

• Copy the complete code into a standard module (eg Module1 ).
• Adjust the const ants including the worksheet if necessarry.
• Only run the first Sub , the rest is being called.

The Code

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