搜索特定单词并删除不完全匹配的所有行 [英] Search specific word and delete all rows which do not contain exact match
问题描述
我有一个包含3000行的Excel工作表.目标是我在 Inputbox 中输入要搜索的列，在另一个 Inputbox 中搜索一个字，VBA宏会删除所有不符合条件的行.
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.
有人协助我将其组合在一起，但结果并非100％预期.如果我在 Inputbox 中插入单词，则需要插入的结果，而不是单数或复数.
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
我想要上面的脚本中的内容:输入框，必须为其搜索列.(已经写好了)
用于搜索的单词的 Inputbox (已经写好，但已显示 Tree 和 Trees )
Excel工作表的第一行不得删除
所有不符合输入框条件的行将被删除
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?
- 单词始终以大写字母开头(例如，树)
- 该单词可以是一个独立的单词(例如Tree)
- 单词的末尾(两个单词之间)，有一个;符号和一个空格(例如，树；叶子)(仅在多个单词的情况下)
- 在单词的开头(两个单词之间)，有一个;符号和一个空格(例如，Leaf； Tree)或(Leaf； Tree； Page)(仅在以下情况下可用)多个单词)
- The word is always starting with a capital letter (e.g. Tree)
- The word can be a standalone word (e.g. Tree)
- At the end of the word (between 2 words), a ;-sign and a space is available (e.g., Tree; Leaf) (ONLY in case of multiple words)
- At the beginning of the word (between 2 words), a ;-sign and a space is available (e.g., Leaf; Tree) or (Leaf; Tree; Page) (ONLY in case of multiple words)
推荐答案
基于单元格子字符串删除行
- 将完整代码复制到标准模块(例如
Module1)中. - 如有必要，调整 const 蚂蚁，包括
worksheet. - 仅运行第一个Sub ，其余的将被调用.
- Copy the complete code into a standard module (e.g.
Module1). - Adjust the constants including the
worksheetif necessarry. - Only run the first Sub, the rest is being called.
Delete Rows Based on Cell Sub String
代码
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
这篇关于搜索特定单词并删除不完全匹配的所有行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
