Option Explicit
Sub test()
Dim arr, i, j, m, mark
mark = Sheets("sheet2").[a1].CurrentRegion
arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1)
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(mark, 1)
If InStr(arr(i, 3), mark(j, 1)) Then Exit For
Next
If j = UBound(mark, 1) + 1 Then
m = m + 1
For j = 1 To UBound(arr, 2)
arr(m, j) = arr(i, j)
Next
End If
Next
With Sheets("sheet1").[a2]
.Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents
If m > 0 Then .Resize(m, UBound(arr, 2)) = arr
End With
End Sub |