搜索特定單詞並刪除所有不包含完全匹配的行

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