Vba/Macro Search Rows for value and copy/paste accordingly

Hi Aquabat

This Code is in the attached and appears to do as you require...let me know of issues...keyboard shortcut...CTRL + x

Option Explicit

Sub Create_Reports()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim cel As Range
    Dim LR As Long
    Dim vWs As Variant

    Set ws1 = Sheets("Store Ad Display")
    Set ws2 = Sheets("Core Products")
    Set ws3 = Sheets("Email to Locals")

    Application.ScreenUpdating = False
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If

    With ws1
        LR = .Range("C" & .Rows.Count).End(xlUp).Row

        .Range("C2:C" & LR).AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True

        ActiveWorkbook.Names.Add Name:="Products", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
    End With

    For Each cel In Range("Products")
        For Each vWs In Array(ws1, ws2, ws3)
            With vWs
                Select Case vWs.Name
                Case ws1.Name
                    With ws1
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=3, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Store Ad" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Store Ad"
                            Else
                                Sheets(cel.Value & " Store Ad").Cells.Clear
                            End If
                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Store Ad")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Store Ad"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With
                Case ws2.Name
                    With ws2
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=4, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Core products" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Core products"
                            Else
                                Sheets(cel.Value & " Core products").Cells.Clear
                            End If

                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Core products")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Core products"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With
                Case ws3.Name
                    With ws3
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=7, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Email to Locals" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Email to Locals"
                            Else
                                Sheets(cel.Value & " Email to Locals").Cells.Clear
                            End If

                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Email to Locals")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Email to Locals"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With

                End Select
            End With
        Next vWs
    Next cel
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub