VBA查找所有单元格包含和复制相邻
大家早上好，
我一直在试图在这里find一个线索，将涵盖我的情况，但我一直不成功。 我正在尝试search包含特定string值的所有单元格（如果可能的话多个string，例如
"*Text*Text*" that would find "123Text123Text123" ）
在给定的范围内，并从该行返回一个ID引用。 到目前为止，我已经设法使用“如果Cell.Value = xxx”场景，但是这只能查找完全匹配，而不是包含 ：
intMyVal = InputBox("Please enter Sales Order No.") lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row newrow = 1 For Each Cell In Range("D2:D" & lngLastRow) 'Data to search If Cell.Value = intMyVal Then Cells(Cell.Row, 1).Copy 'Copy ID1 value Sheets("TempData").Cells(newrow, 1).PasteSpecial xlPasteValues 'Paste ID1 value in temp data newrow = newrow + 1 End If Next Cell
下图显示了我所指的数据摘录。 D列将需要search特定的文本string（例如“Tesco”或“Ireland”），并且对于每个命中，列A中的对应值将需要被复制到临时数据页面。
如果任何人都可以build议使用VBA这样做的正确方法发现这将是伟大的。
在此先感谢，丹
而不是看每个细胞使用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
解决scheme很简单：使用Like运算符： If someCell.Value Like "*Text*Text*" Then就会做到你想要的。
在你的情况下，我想这将是：
If Cell.Value Like "*" & intMyVal & "*" Then