loop code through each slicer value selection

Question

I have a PivotTable with a slicer that has 5 filters. I'm looking to have these filters to each be selected individually one by one and run a copy/paste code for every filter selected.

I've set up the code to work for each filter so far with completely rewriting/copying each code for each filter and everything works but it seems like a lot of unnecessary code

Sub InsertData()
Dim wsCopy As Worksheet, wsDest As Worksheet
Dim DefCopyLastRow As Long, DefDestLastRow As Long
'Set variables for copy and destination sheets
Set wsCopy = Workbooks("Warranty Template.xlsm").Worksheets("PivotTable")
Set wsDest = Workbooks("QA Matrix Mar 2019 copy.xlsm").Worksheets("Plant Sheet")
'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row
'3. Copy & Paste Data For Each Filter Selection
'Backhoes
With ActiveWorkbook.SlicerCaches("Slicer_Model_Family_Description")
 .SlicerItems("Backhoes Case Burlington").Selected = True
 .SlicerItems("CE Tractor Loader Burlington").Selected = False
 .SlicerItems("Corn Headers Burlington").Selected = False
 .SlicerItems("Dozer Case Calhoun Burlington").Selected = False
 .SlicerItems("Draper & Pickup Headers Burlington").Selected = False
 .SlicerItems("Forklift Case Burlington").Selected = False
 .SlicerItems("Grain Headers Burlington").Selected = False
 If .SlicerItems("Backhoes Case Burlington").Selected Then
'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row
'3. Copy and Paste Data
wsCopy.Range("A5:A" & DefCopyLastRow).Copy
wsDest.Range("J" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("L" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("M" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("D5:D" & DefCopyLastRow).Copy
wsDest.Range("P" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("E5:E" & DefCopyLastRow).Copy
wsDest.Range("S" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
NewLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Row
wsDest.Range("AG" & DefDestLastRow & ":AG" & NewLastRow).Value = "Final Customer"
wsDest.Range("D" & DefDestLastRow & ":D" & NewLastRow).Value = "TLB"
End If
End With
'TLs
With ActiveWorkbook.SlicerCaches("Slicer_Model_Family_Description")
 .SlicerItems("Backhoes Case Burlington").Selected = False
 .SlicerItems("Backhoes Case Burlington").Selected = False
 .SlicerItems("CE Tractor Loader Burlington").Selected = True
 .SlicerItems("Corn Headers Burlington").Selected = False
 .SlicerItems("Dozer Case Calhoun Burlington").Selected = False
 .SlicerItems("Draper & Pickup Headers Burlington").Selected = False
 .SlicerItems("Forklift Case Burlington").Selected = False
 .SlicerItems("Grain Headers Burlington").Selected = False
 If .SlicerItems("CE Tractor Loader Burlington").Selected Then
'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row
'3. Copy and Paste Data
wsCopy.Range("A5:A" & DefCopyLastRow).Copy
wsDest.Range("J" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("L" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("M" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("D5:D" & DefCopyLastRow).Copy
wsDest.Range("P" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("E5:E" & DefCopyLastRow).Copy
wsDest.Range("S" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
NewLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Row
wsDest.Range("AG" & DefDestLastRow & ":AG" & NewLastRow).Value = "Final Customer"
wsDest.Range("D" & DefDestLastRow & ":D" & NewLastRow).Value = "TL"
End If
End With
'Corn
With ActiveWorkbook.SlicerCaches("Slicer_Model_Family_Description")
 .SlicerItems("CE Tractor Loader Burlington").Selected = False
 .SlicerItems("CE Tractor Loader Burlington").Selected = False
 .SlicerItems("Backhoes Case Burlington").Selected = False
 .SlicerItems("Corn Headers Burlington").Selected = True
 .SlicerItems("Dozer Case Calhoun Burlington").Selected = False
 .SlicerItems("Draper & Pickup Headers Burlington").Selected = False
 .SlicerItems("Forklift Case Burlington").Selected = False
 .SlicerItems("Grain Headers Burlington").Selected = False
 If .SlicerItems("Corn Headers Burlington").Selected Then
'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row
'3. Copy & Paste Data For Each Filter Selection
wsCopy.Range("A5:A" & DefCopyLastRow).Copy
wsDest.Range("J" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("L" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("B5:B" & DefCopyLastRow).Copy
wsDest.Range("M" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("D5:D" & DefCopyLastRow).Copy
wsDest.Range("P" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
wsCopy.Range("E5:E" & DefCopyLastRow).Copy
wsDest.Range("S" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues
NewLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Row
wsDest.Range("AG" & DefDestLastRow & ":AG" & NewLastRow).Value = "Final Customer"
wsDest.Range("D" & DefDestLastRow & ":D" & NewLastRow).Value = "Corn"
End If
End With
End Sub

The [COPY/PASTE CODE HERE] should be the same code for all slicers which is why I assume looping would be a more efficient way of setting this up

Answer 1

Repeating code within a subroutine is a sign that the procedure needs to be broken up into multiple subroutines. Ideally, a subroutine should perform only one or two tasks. Delegating tasks to other subroutines makes the project easier to read, modify and debug.

Consider the code below. You can easily test the various slicer filters without having to run the whole code. You can also test the column assignments individually.

Sub InsertData()
 'Backhoes
 FilterSlicer_Model_Family_Description False, True, False, False, False, False, False
 AppendAllColumnsToPlanetSheets
 FillAGandD "TLB"
 'TLs
 FilterSlicer_Model_Family_Description True, False, False, False, False, False, False
 AppendAllColumnsToPlanetSheets
 FillAGandD "TL"
 'Corn
 FilterSlicer_Model_Family_Description False, False, True, False, False, False, False
 AppendAllColumnsToPlanetSheets
 FillAGandD "Corn"
End Sub
Sub AppendAllColumnsToPlanetSheets()
 AppendColumnDataToPlanetSheets "A", "J"
 AppendColumnDataToPlanetSheets "B", "L"
 AppendColumnDataToPlanetSheets "B", "M"
 AppendColumnDataToPlanetSheets "D", "P"
 AppendColumnDataToPlanetSheets "S", "AG"
End Sub
Sub AppendColumnDataToPlanetSheets(SourceColumn As Variant, DestColumn As Variant)
 Dim Values As Variant
 With Workbooks("Warranty Template.xlsm").Worksheets("PivotTable")
 Values = .Range(.Cells(5, SourceColumn), .Cells(.Rows.Count, SourceColumn).End(xlUp)).Value
 End With
 With Workbooks("QA Matrix Mar 2019 copy.xlsm").Worksheets("Plant Sheet")
 With .Cells(.Rows.Count, DestColumn).End(xlUp).Offset(1)
 .Resize(UBound(Values)).Values = Values
 .EntireRow.Columns("AG").Value = "Final Customer"
 .EntireRow.Columns("D").Value = ColumnDValue
 End With
 End With
End Sub
Sub FillAGandD(ColumnDValue As String)
 With Workbooks("QA Matrix Mar 2019 copy.xlsm").Worksheets("Plant Sheet")
 With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
 .Resize(UBound(Values)).Values = Values
 .EntireRow.Columns("AG").Value = "Final Customer"
 .EntireRow.Columns("D").Value = ColumnDValue
 End With
 End With
End Sub
Sub FilterSlicer_Model_Family_Description(CETractorLoaderBurlington As Boolean, _
 BackhoesCaseBurlington As Boolean, _
 CornHeadersBurlington As Boolean, _
 DozerCaseCalhounBurlington As Boolean, _
 DraperPickupHeadersBurlington As Boolean, _
 ForkliftCaseBurlington As Boolean, _
 GrainHeadersBurlington As Boolean)
 With ActiveWorkbook.SlicerCaches("Slicer_Model_Family_Description")
 .SlicerItems("CE Tractor Loader Burlington").Selected = CETractorLoaderBurlington
 .SlicerItems("Backhoes Case Burlington").Selected = BackhoesCaseBurlington
 .SlicerItems("Corn Headers Burlington").Selected = CornHeadersBurlington
 .SlicerItems("Dozer Case Calhoun Burlington").Selected = DozerCaseCalhounBurlington
 .SlicerItems("Draper & Pickup Headers Burlington").Selected = DraperPickupHeadersBurlington
 .SlicerItems("Forklift Case Burlington").Selected = ForkliftCaseBurlington
 .SlicerItems("Grain Headers Burlington").Selected = GrainHeadersBurlington
 End With
End Sub

• aNobleNoob: how would I set this up to run with the push of one button?
• TinMan: Inserdata runs the whole sequence.