Search and copy based on partial text match

Hi everyone!

I have a list in Column A with 1000 Rows, all are texts. In D1 and E1 I have two texts, which would be the search criterias.
I'd like to search the Column A, if the values in D1 and E1 are part of a row simultaneously but it can be only partial match. I cannot use VLOOKUP because it can give multiple results. The results should be listed in a separate sheet. Here is an example:

Column A
ABD_DDT_VitaminB12
ABD_dka_VitaminB2
ABD_dka_VitaminB2_version2
DAT_kft_VItaminB2

And I'd like to see in a separate sheet only the rows which contains "ABD" and "VitaminB2"

Thank you!

Hi,

can be done with an advanced filter with or whitout any code …

Try this:

Sub RunMe()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet:   Set ws2 = Sheets("Sheet2")
Dim LR As Long, LC As Long
Dim rCell As Range, rSearch As Range, str1Find As Range, str2Find As Range
Dim str1 As String, str2 As String

LR = ws1.Range("A" & Rows.Count).End(xlUp).Row
LC = ws1.UsedRange.Columns.Count

str1 = ws1.Range("D1").Value
str2 = ws1.Range("E1").Value

For Each rCell In ws1.Range("A2:A" & LR)
    Set rSearch = rCell.Resize(1, LC + 1)
    Set str1Find = rSearch.Find(What:=str1, LookIn:=xlValues, Lookat:=xlPart)
    Set str2Find = rSearch.Find(What:=str2, LookIn:=xlValues, Lookat:=xlPart)
    If Not str2Find Is Nothing And Not str1Find Is Nothing Then
        rCell.EntireRow.Copy Destination:=ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
Next rCell

End Sub

Try on a copy 1st. Copies to Sheet2.

Sub PIQalap()
Dim rcell As Range
Columns(2).Insert
Columns(2).Insert
Range("B2:B" & Range("A" & Rows.count).End(3)(1).Row).Formula = "=VLOOKUP(""*"" & $F$1 & ""*"",$A2:$A2,1,FALSE)"
Range("C2:C" & Range("A" & Rows.count).End(3)(1).Row).Formula = "=VLOOKUP(""*"" & $G$1 & ""*"",$A2:$A2,1,FALSE)"
With Range("B2:C" & Range("A" & Rows.count).End(3)(1).Row)
    .Value = .Value
    .Replace "#N/A", ""
End With
Exit Sub
For Each rcell In Range("B2:B" & Range("A" & Rows.count).End(3)(1).Row)
    If rcell.Value <> "" And rcell.offset(, 1).Value <> "" Then
        rcell.EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.count).End(3)(2)
    ElseIf rcell.offset(, 1).Value <> "" And rcell.Value <> "" Then
        rcell.EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.count).End(3)(2)
    End If
Next rcell
Columns("B:C").Delete
End Sub

Thanks! The first one works perfectly! You made my day :D