我尝试了Find函数，但它只搜索单个值...我需要在同一个单元格中搜索包含多个值的单元格。 即包含“新”“汽车”“红色”的单元格
编辑1，这就是我现在所拥有的......非常感谢您的评论和帮助。它现在正在运作，我希望进一步优化。
Private Sub Run_Click()
Dim Val As Variant, v5 As Range, Count As Long, Temp1 As String, Temp2 As String, Temp3 As String
Dim pos1, pos2, pos3 As Integer
Dim Centinel1, Centinel2 As Boolean
Centinel1 = True
While Centinel1 = True
i = 2
Val = Cells(i, 1).Value
If Val <> "" Then
Count = 0
' Gather values from source
v1 = Cells(i, 1).Value
v2 = Cells(i, 2).Value
v3 = Left(Cells(i, 3).Value, 3)
v4 = Mid(Cells(i, 3).Value, InStrRev(Cells(i, 3).Value, "-") - 2, 2)
Centinel2 = True
Temp1 = "$B$2"
While Centinel2 = True
Set v5 = Sheets("RWI").Range("B1:B1000").Find(What:=v1, After:=Range(Temp1))
pos1 = InStr(v5, v2)
pos2 = InStr(v5, v3)
pos3 = InStr(v5, v4)
Temp2 = v5.Address
GetTail1 = Mid(Temp1, InStrRev(Temp1, "$") + 1)
GetTail2 = Mid(Temp2, InStrRev(Temp2, "$") + 1)
'Check if all matches are within "Find"
If pos1 > 1 And pos2 > 1 And pos3 > 1 Then
MsgBox v5 & " " & Sheets("RWI").Range(v5.Address).Offset(, -1)
Centinel2 = False
ElseIf Temp1 > Temp2 Then
MsgBox "Description not found."
Centinel2 = False
Else
Temp1 = v5.Address
End If
Wend
i = i + 1
Centinel1 = False
Else
Centinel1 = False
End If
Wend
End Sub
编辑3：这就是我现在的代码......
Private Sub Run_Click()
Dim Val As Variant, v5 As Range, Count As Long, i As Long
Dim GetTail1, GetTail2 As Long
Dim Cellsave, Temp1, Temp2, Temp3, v1, v2, v3, v4, R, Sheet, v0, v22 As String
Dim pos1, pos2, pos3 As Integer
Dim Centinel1, Centinel2, Centinel3 As Boolean
If RWbutton.Value = True Then
R = "RW-"
Sheet = "RW Overflow Sheet"
ElseIf RWIbutton.Value = True Then
R = "RWI-"
Sheet = "RWI Overflow Sheet"
End If
Centinel1 = True
i = 2
If Me.ResultsCol.Value = "" Then
MsgBox "Please input valid column letter to save results at"
Else
While Centinel1 = True
Val = Sheets(Sheet).Cells(i, 1).Value
If Val <> "" Then
Count = 0
Centinel3 = False
' Gather values from source
v0 = R
v1 = "-" & Sheets(Sheet).Cells(i, 1).Value & "-"
' Check if v2 has - or (A or B)
If Sheets(Sheet).Cells(i, 2).Value Like "*-*" And (Sheets(Sheet).Cells(i, 2).Value Like "*A*" Or Sheets(Sheet).Cells(i, 2).Value Like "*B*") Then
v2 = Left(Sheets(Sheet).Cells(i, 2).Value, Application.Find("-", Sheets(Sheet).Cells(i, 2).Value) - 1) & "-"
v22 = Right(Sheets(Sheet).Cells(i, 2).Value, 1)
Centinel3 = True
ElseIf Sheets(Sheet).Cells(i, 2).Value Like "*-*" Then
v2 = "-" & Right(Sheets(Sheet).Cells(i, 2).Value, (Len(Sheets(Sheet).Cells(i, 2).Value) - InStrRev(Sheets(Sheet).Cells(i, 2).Value, "-")))
Else
v2 = Sheets(Sheet).Cells(i, 2).Value & "-"
End If
v3 = Left(Sheets(Sheet).Cells(i, 3).Value, 3)
v4 = Right(Sheets(Sheet).Cells(i, 3).Value, (Len(Sheets(Sheet).Cells(i, 3).Value) - InStrRev(Sheets(Sheet).Cells(i, 3).Value, "/")))
Cellsave = Me.ResultsCol.Value & i
Centinel2 = True
Temp1 = "$B$1"
While Centinel2 = True
Set v5 = Sheets("fnd_gfm").Range("B1:B1000").Find(What:=v0, After:=Range(Temp1))
If (Not v5 Is Nothing) Then
pos1 = InStr(v5, v1)
pos2 = InStr(v5, v2)
pos3 = InStr(v5, v3)
pos4 = InStr(v5, v4)
Temp2 = v5.Address
GetTail1 = Mid(Temp1, InStrRev(Temp1, "$") + 1)
GetTail2 = Mid(Temp2, InStrRev(Temp2, "$") + 1)
'Check if all matches are within "Find"
If pos1 > 1 And pos2 > 1 And pos3 > 1 And pos4 > 1 Then
'Check if Part Number has A or B in it
If Centinel3 = False Then
Sheets(Sheet).Range(Cellsave).Value = Sheets("fnd_gfm").Range(v5.Address).Offset(, -1)
Centinel2 = False
ElseIf Centinel3 = True Then
Sheets(Sheet).Range(Cellsave).Value = Left(Sheets("fnd_gfm").Range(v5.Address).Offset(, -1).Value, (Len(Sheets("fnd_gfm").Range(v5.Address).Offset(, -1).Value) - 1)) & v22
Centinel2 = False
Centinel3 = False
End If
ElseIf GetTail1 > GetTail2 Then
'Check when Find does not find the value
Sheets(Sheet).Range(Cellsave).Value = "Not found."
Centinel2 = False
Else
Temp1 = v5.Address
End If
Else
Sheets(Sheet).Range(Cellsave).Value = "Not found."
Centinel2 = False
End If
Wend
i = i + 1
Else
Centinel1 = False
MsgBox "Process Finished"
End If
Wend
End If
End Sub
答案 0 :(得分：0)
更新：代码已经增强，更加用户友好，因为我有一天会发现自己想要使用它。它使用数组通过输入框存储文本字段，因此搜索项目的数量很多。
Sub FindLots()
Dim TextArray() As String, WS As Worksheet, Targetcell As Range
Dim Answer As String, StartingAddress As String
Dim AllSearchText As String, QuestionHeader As String
Dim I As Integer, t As Integer, NumericAnswer As Integer
Dim NoMemberFound As Boolean
StartQuestion:
If I = 0 Then
QuestionHeader = "Enter Your Search Text"
Else
QuestionHeader = "Enter Your Search... part " & I + 1 & " !"
End If
Answer = InputBox("Add a field to search for and hit ""OK."" You will get a chance to enter search fields.", QuestionHeader, "Enter Text")
If Answer = "" Then
NumericAnswer = MsgBox("You didn't enter anything. Click ""Yes"" to try again. ""No"" to start search or ""Cancel"" to... cancel.", vbYesNoCancel, "Oh False!")
If NumericAnswer = vbYes Then
GoTo StartQuestion
ElseIf NumericAnswer = vbCancel Then
Exit Sub
End If
Else
ReDim Preserve TextArray(I)
TextArray(I) = Answer
AllSearchText = AllSearchText & "," & Answer
NumericAnswer = MsgBox("Would you like to add an additional members to search of """ & AllSearchText & """? Click no to continue search.", vbQuestion + vbYesNoCancel)
If NumericAnswer = vbYes Then
I = I + 1
GoTo StartQuestion
ElseIf NumericAnswer = vbCancel Then
Exit Sub
End If
End If
On Error Resume Next
If TextArray(0) = "" Then
MsgBox "No Search text entered", vbCritical
Exit Sub
End If
On Error GoTo 0
Set WS = ActiveSheet 'or whatever sheet you want to search
Set Targetcell = WS.Cells.Find(TextArray(0), WS.Cells(1, 1))
If Targetcell Is Nothing Then
MsgBox "coulnd't even find " & TextArray(0), vbCritical
Exit Sub
ElseIf I = 0 Then
MsgBox "Found your cell at " & Targetcell.Address
Targetcell.Select
Exit Sub
End If
StartingAddress = Targetcell.Address
Do
NoMemberFound = False
For t = 1 To I
If Targetcell.Cells.Find(TextArray(t)) Is Nothing Then
NoMemberFound = True
Exit For
End If
Next t
If NoMemberFound = False Then
MsgBox "Found your cell at " & Targetcell.Address, , "Yea!"
Targetcell.Select
Exit Sub
End If
Set Targetcell = WS.Cells.Find(TextArray(0), Targetcell)
Loop Until Targetcell.Address = StartingAddress
MsgBox "Unable to find cells with your criteria of " & Right(AllSearchText, Len(AllSearchText) - 1), vbInformation, "Is that bad?"
End Sub