Pivot filter by each item and copy to new sheet

[Paul_Hossler]

Something like this

Option Explicit


Sub MakeSheets()
    Dim oPivotTable As PivotTable
    Dim oPageField As PivotField
    Dim oPageItem As PivotItem
    Dim aryPageItems() As String
    Dim cntPageItems As Long, idxPageItems As Long


    If ActiveSheet.PivotTables.Count = 0 Then Exit Sub
    Set oPivotTable = ActiveSheet.PivotTables(1)
    
    If oPivotTable.PageFields.Count = 0 Then Exit Sub
    Set oPageField = oPivotTable.PageFields(1)


    For Each oPageItem In oPageField.PivotItems
        With oPageItem
            If .Visible Then
                cntPageItems = cntPageItems + 1
                ReDim Preserve aryPageItems(1 To cntPageItems)
                aryPageItems(cntPageItems) = .Value
            End If
        End With
    Next


'    Application.ScreenUpdating = False


    On Error Resume Next
    Application.DisplayAlerts = False
    For idxPageItems = LBound(aryPageItems) To UBound(aryPageItems)
        Worksheets(aryPageItems(idxPageItems)).Delete
    Next idxPageItems
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    oPivotTable.ShowPages PageField:=oPageField.Value


    For idxPageItems = LBound(aryPageItems) To UBound(aryPageItems)
        With Worksheets(aryPageItems(idxPageItems))
            .Activate
            
            Application.StatusBar = ActiveSheet.Name
            
            DoEvents
            
            .PivotTables(1).TableRange2.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            .Cells(1, 1).Resize(oPivotTable.PageFields.Count + 1, 1).EntireRow.Delete
            
            .Range("A2").Select
            With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
            End With
            ActiveWindow.FreezePanes = True
            
            .Cells(1, 1).CurrentRegion.Rows(1).Interior.ColorIndex = 15
            .Cells(1, 1).CurrentRegion.Font.Bold = True
        End With
    Next idxPageItems
    
    Application.StatusBar = False
    Application.ScreenUpdating = True


    MsgBox "Done"
    
End Sub