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

TinMan · Accepted Answer · 2019-07-13 16:21:41Z

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

\$\begingroup\$ how would I set this up to run with the push of one button? \$\endgroup\$ – aNobleNoob Jul 15 at 11:24 — aNobleNoob, Jul 15 at 11:24
\$\begingroup\$ Inserdata runs the whole sequence. \$\endgroup\$ – TinMan Jul 15 at 11:29 — TinMan, Jul 15 at 11:29

Stack Exchange Network

current community

your communities

more stack exchange communities

loop code through each slicer value selection

1 Answer 1

Your Answer

Not the answer you're looking for? Browse other questions tagged vba excel or ask your own question.

Hot Network Questions

loop code through each slicer value selection

1 Answer 1

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged vba excel or ask your own question.

Related

Hot Network Questions