Search code examples
excelvbapivot-tableslicers

I am looking to loop through a slicer and select the next item and the next to print a pivot


I have a slicer linked to 2 pivot tables. I want to loop through the slicer from the first item to the last item and print the corresponding tables.

I have tried the following code:

Sub Slicerloop
    Dim sI As SlicerItem, sI2 As SlicerItem, sC As SlicerCache
    Set sC = ActiveWorkbook.SlicerCaches("Slicer_UID")
    With sC
        For Each sI In sC.SlicerItems
            For Each sI2 In sC.SlicerItems
                If sI.Name = sI2.Name Then sI2.Selected = True Else: sI2.Selected = False
            Next        
        Next
    End With        
End Sub

There are no errors messages, but this does not select the next entry and thus change the pivot table.


Solution

  • By this you can loop over all sliceritems and use their individual caption for a screenshot of your pivottable.

    Private Sub LoopAllSlicerItemsAndCapturePivottable()
        Dim sc As Excel.SlicerCache
        Dim si As Excel.SlicerItem, siDummy As Excel.SlicerItem
        Dim pt As Excel.PivotTable
        Dim co As Excel.ChartObject
        Dim wsBlank As Excel.Worksheet
    
        Set sc = ActiveWorkbook.SlicerCaches("Slicer_UID")
        Set pt = sc.PivotTables(1)
    
        ' add a blank sheet to get a blank Chart instead of PivotChart later 
        Set wsBlank = ActiveWorkbook.Sheets.Add
    
        For Each si In sc.SlicerItems
            sc.ClearManualFilter
            For Each siDummy In sc.SlicerItems
                siDummy.Selected = (si.Name = siDummy.Name)
            Next siDummy
    
            ' now only 1 sliceritem is selected and can be used
            With pt.TableRange2 ' or TableRange1
                .CopyPicture Appearance:=xlScreen, Format:=xlPicture
                Set co = wsBlank.ChartObjects.Add(1, 1, .Width, .Height)
                co.Select
                co.Chart.Paste
                co.Chart.Export _
                    fileName:=ActiveWorkbook.Path & "\Whatever " & si.Caption & ".png", _
                    filtername:="PNG"
                co.Delete
            End With
        Next si
    
        Application.DisplayAlerts = False
        wsBlank.Delete
        Application.DisplayAlerts = True
    
    End Sub