Copying Rows with multiple "Keywords" to new Spreadsheet

[McMattyO]

Hi,
I am trying to copy certain ROWS from my "DATA" sheet to my "Planning" worksheet with a MACRO, and am having some issues with adding more than 1 Keyword to my search. Right now my Key word is "PFP", and the only way I found to search for another keyword is write out the formula below it in italic, with additional keyword "BBEG". I need to add about 20 keywords and when I type it out this way they all won't fit on the same line, and if I try to move down a line I get an error. Any help in advance on how I should write the code is greatly appreciated, and as a bonus if there is a way to write this so that it searches faster that would be great since I have 3k Rows. Thanks, Matt


Private Sub planner()
a = Worksheets("DATA").Cells(Rows.Count, 1).End(xlUp).Row


For i = 2 To a




If (Worksheets("DATA").Cells(i, 5).Value = "PFP") Then
If (Worksheets("DATA").Cells(i, 5).Value = "PFP" Or Worksheets("DATA").Cells(i, 5).Value = "BBEG") Then

Worksheets("DATA").Rows(i).Copy


Worksheets("Planning").Activate

b = Worksheets("Planning").Cells(Rows.Count, 1).End(xlUp).Row


Worksheets("Planning").Cells(b + 1, 1).Select


ActiveSheet.Paste


Worksheets("DATA").Activate


End If
Next


Application.CutCopyMode = False


ThisWorkbook.Worksheets("DATA").Cells(1, 1).Select




End Sub

 

[footoo]

Private Sub planner()
Dim ray: ray = Array("a", "b", "d") 'Change as required
With Sheets("DATA")
.[E:E].AutoFilter Field:=1, Criteria1:=ray, Operator:=xlFilterValues
.Range(.[E2], .Cells(Rows.Count, "E").End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
    Sheets("Planning").Cells(Rows.Count, "A").End(xlUp)(2)
.[E:E].AutoFilter
End With
End Sub

 

[My Aswer Is This]

Try this:
My sample filter filter's Pie Apple Coffee

Modify these values with your own. Add more as you need.​

Sub Filter_Me_With_Array()
'Modified  8/8/2018  8:59:32 PM  EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim Counter As Long
c = 5 ' Column Number Modify this to your need
Lastrow = Sheets("Data").Cells(Rows.Count, c).End(xlUp).Row
Lastrowa = Sheets("Planning").Cells(Rows.Count, c).End(xlUp).Row + 1

With ActiveSheet.Cells(1, c).Resize(Lastrow)
    .AutoFilter 1, Criteria1:=Array("Apples", "Pie", "Coffee"), Operator:=xlFilterValues
    Counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If Counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Planning").Rows(Lastrowa)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
End Sub

 

[My Aswer Is This]

Or Like footo plan
My script would look like this:

Sub Filter_Me_With_Array()
'Modified  8/8/2018  9:14:55 PM  EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim Counter As Long
Dim Del As Variant
Del = Array("Apples", "Pie", "Coffee")
c = 5 ' Column Number Modify this to your need
Lastrow = Sheets("Data").Cells(Rows.Count, c).End(xlUp).Row
Lastrowa = Sheets("Planning").Cells(Rows.Count, c).End(xlUp).Row + 1
With ActiveSheet.Cells(1, c).Resize(Lastrow)
    .AutoFilter 1, Criteria1:=Del, Operator:=xlFilterValues
        Counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If Counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Planning").Rows(Lastrowa)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
End Sub

 

[McMattyO]

Thank you very much! I will try it when I get into the office in the morning!

 

[McMattyO]

Thank you footoo!