VBA查找包含和复制相邻的所有单元格

Question

早上好，

我一直试图在这里找到一个可以涵盖我的情况的线程，但我没有成功。我正在尝试搜索包含特定字符串值的所有单元格（如果可能的话，多个字符串，例如

PASSWORD(...)）

在给定范围内并从该行返回ID引用。到目前为止，我已设法使用＆＃34; If Cell.Value = xxx＆＃34;但是，这只会查找完全匹配，而不是包含：

"*Text*Text*" that would find "123Text123Text123"

以下图片显示了我所指的数据的摘录。需要搜索D列以查找特定的文本字符串（例如＆＃34; Tesco＆＃34;或＆＃34; Ireland＆＃34;）并且对于每个匹配，A列中的相应值将需要复制到临时数据页。

如果有人可以建议使用VBA查找的正确方法，那将会很棒。

提前致谢， 丹

Answer 1

使用FIND和FINDNEXT：

，而不是查看每个单元格

Public Sub FindSales()

    Dim sValToFind As String
    Dim rSearchRange As Range
    Dim sFirstAdd As String
    Dim rFoundCell As Range
    Dim rAllFoundCells As Range
    Dim sMessage As String

    sValToFind = InputBox("Please enter Sales Order No.")
    'Code to check a valid number entered
    '.
    '.

    With ThisWorkbook.Worksheets("Sheet1")
        Set rSearchRange = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With

    With rSearchRange
         Set rFoundCell = .Find(sValToFind, LookIn:=xlValues, LookAt:=xlPart)
         If Not rFoundCell Is Nothing Then
            sFirstAdd = rFoundCell.Address
            Do

                sMessage = sMessage & rFoundCell.Row & ", "

                'Create a range of found cells.
                If Not rAllFoundCells Is Nothing Then
                    Set rAllFoundCells = Union(rAllFoundCells, rFoundCell)
                Else
                    Set rAllFoundCells = rFoundCell
                End If
                Set rFoundCell = .FindNext(rFoundCell)
            Loop While rFoundCell.Address <> sFirstAdd
         End If
    End With

    rAllFoundCells.Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Range("A1")

    sMessage = sValToFind & " found on rows " & Mid(sMessage, 1, Len(sMessage) - 2) & "."
    MsgBox sMessage, vbOKOnly + vbInformation

End Sub

Answer 2

解决方案很简单：使用Like运算符：If someCell.Value Like "*Text*Text*" Then可以完全按照您的意愿执行。

在你的情况下，我想它会是：

If Cell.Value Like "*" & intMyVal & "*" Then