VBA Copy and Paste to new tab based on Autofilter - Troubleshooting blanks

[Nfig]

Hi, I'm trying to figure something out with a macro that I'm working on. I'm not very experienced with macros but I'm figuring it out as I go, and what I want to accomplish is working EXCEPT when the source table doesn't have data for a particular filter. Here are the details (with fictional data):

I have a master template with tabs for Apples, Oranges, Peaches, Grapes, and Bananas. Each year I will have data from 10 different farms, and I will be saving new Excel files from the template for each farm for each year. To do this I will copy the raw data from Farm 1 into a tab in the template (“Source Data”), run the macro to filter and copy and paste by each fruit into the respective tab. Then save as “Farm 1 – 2019.” I will do the same for each farm.

The problem is that not all farms have all 5 fruits. When the macro runs the filter and there aren’t any results in the table, it ends up copying ALL the data in the table. For example, if Farm 2 does not have Oranges, when the macro gets to filtering by “Oranges,” it will copy everything and paste it into the “Orange Data Tab.”

(For reference, the table headers are in Row 4.)

Sheets("Source Data").Select
Selection.End(xlToLeft).Select
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
"Apples"
Range("B5:F5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Apple Data Tab").Select
Range("A8").Select
ActiveSheet.Paste
Sheets("Source Data").Select
Range("G5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Apple Data Tab").Select
Range("G8").Select
ActiveSheet.Paste
Sheets("Source Data").Select
Range("H5:I5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Apple Data Tab").Select
Range("I8").Select
ActiveSheet.Paste
Sheets("Source Data").Select
Selection.End(xlToLeft).Select
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
"Oranges"
Range("B5:F5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Orange Data Tab").Select
Range("A8").Select
ActiveSheet.Paste
Sheets("Source Data").Select
Range("G5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Orange Data Tab").Select
Range("G8").Select
ActiveSheet.Paste
Sheets("Source Data").Select
Range("H5:I5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Orange Data Tab").Select
Range("I8").Select
ActiveSheet.Paste

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub Nfig()
    Dim Ary As Variant
    Dim i As Long
    
    Ary = Array("Apples", "Apple Data Tab", "Oranges", "Orange Data Tab", "Grapes", "Grape Data Tab")
    With Sheets("Source Data").ListObjects("Table1")
        For i = 0 To UBound(Ary) Step 2
            .Range.AutoFilter 1, Ary(i)
            If .Range.Resize(, 1).SpecialCells(xlVisible).Count > 1 Then
                .DataBodyRange.Columns("B:F").Copy Sheets(Ary(i + 1)).Range("A8")
                .DataBodyRange.Columns("G:G").Copy Sheets(Ary(i + 1)).Range("G8")
                .DataBodyRange.Columns("H:I").Copy Sheets(Ary(i + 1)).Range("I8")
            End If
        Next i
    End With
End Sub

 

[Nfig]

Thank you so much! This seems to be working great. The only issue is that my actual list of "fruits" has 24 items (and subsequently 24 tabs), and as I entered them all into the Array list, I eventually got to the end of the line. When I keep typing and it goes to the next line, I get an error. I was able to get 14 of them into the list so far.

Hi & welcome to MrExcel.
How about

Sub Nfig()
    Dim Ary As Variant
    Dim i As Long
   
    Ary = Array("Apples", "Apple Data Tab", "Oranges", "Orange Data Tab", "Grapes", "Grape Data Tab")
    With Sheets("Source Data").ListObjects("Table1")
        For i = 0 To UBound(Ary) Step 2
            .Range.AutoFilter 1, Ary(i)
            If .Range.Resize(, 1).SpecialCells(xlVisible).Count > 1 Then
                .DataBodyRange.Columns("B:F").Copy Sheets(Ary(i + 1)).Range("A8")
                .DataBodyRange.Columns("G:G").Copy Sheets(Ary(i + 1)).Range("G8")
                .DataBodyRange.Columns("H:I").Copy Sheets(Ary(i + 1)).Range("I8")
            End If
        Next i
    End With
End Sub

 

[Fluff]

Are the "Fruits" & the sheet names the same?

 

[Nfig]

No, they aren't the exact same. (We receive files from several sources that have their own naming conventions, and these names are too long for tab names. So we name the tabs something abbreviated and logical.)

Are the "Fruits" & the sheet names the same?

 

[Fluff]

Ok, in that case you will need to create the array like

Ary = Array("Apples", "Apple Data Tab", "Oranges", "Orange Data Tab", "Grapes", "Grape Data Tab", _
           "Pears", "Pears sheet")

that way you can put the array on as many lines as you like