我有一个 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
我读过“查找功能”有一个“匹配整个单元格内容”选项。如何转换已经编写的内容并与新的编码合并?
最佳答案
根据单元格子字符串删除行
Module1
)。 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
关于excel - 搜索特定单词并删除所有不包含完全匹配的行,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/62651211/