调整一个旧的职位的代码

我喜欢这个旧代码来帮助我find单词：

Sub Sample() Dim oRange As Range, aCell As Range, bCell As Range Dim ws As Worksheet Dim SearchString As String, FoundAt As String On Error GoTo Err Set ws = Worksheets("Sheet1") Set oRange = ws.Columns(1) SearchString = "Mike" Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not aCell Is Nothing Then Set bCell = aCell If InStr(1, aCell.Value, "Anderson", vbTextCompare) Then _ FoundAt = aCell.Address Do Set aCell = oRange.FindNext(After:=aCell) If Not aCell Is Nothing Then If aCell.Address = bCell.Address Then Exit Do If InStr(1, aCell.Value, "Anderson", vbTextCompare) Then _ FoundAt = FoundAt & ", " & aCell.Address Else Exit Do End If Loop Else MsgBox SearchString & " not Found" Exit Sub End If MsgBox "The Search String has been found these locations: " & FoundAt Exit Sub Err: MsgBox Err.Description End Sub 

我可以添加更多的名称：searchstring=“迈克”< – 像“”迈克“”安德烈“”等“

Answer 1

或者你可以使用AutoFilter

 Option Explicit Sub Sample() Dim aCell As Range Dim ws As Worksheet Set ws = Worksheets("Sheet1W") Dim searchArray As Variant searchArray = Array("Mike", "Andrea", "Mary") '<--| list your names to search for With ws '<--| reference relevant sheet With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one .AutoFilter Field:=1, Criteria1:=searchArray, Operator:=xlFilterValues '<--| filter it with 'searchArray' array values If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cells other then headers With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) MsgBox "Names: " & vbCrLf & Join(searchArray, ";") & vbCrLf & vbCrLf & "found in cells " & vbCrLf & .Address For Each aCell In .Cells '<--| loop through your matching cells 'your code to handle current matching cell Next End With End If End With .AutoFilterMode = False End With End Sub