Pivot filter by each item and copy to new sheet

[AlbertLind]

Dears,

I have a macro which worked with an older file. The macro filters a pivottable and copy the filtered values into a new sheet. This should be done for each item in the column. In the old file it was a power pivot table.

Now I adopted the macro to my new file with a simple pivot table, but it shows me now an error: application defined or object defined error.

I dont know how to solve the problem. I think it is because of the power pivot...

This is my new code: (the red line is the error)

Sub CreatePlantFiles()

    Dim pt As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    Dim copyrange As Range
    Dim strMsg As String
    Dim namenArray() As String
    Dim i As Integer
    Dim oPI As PivotItem
    Dim ws As Worksheet
 
    Application.ScreenUpdating = False
    
    ctSheet = ThisWorkbook.Sheets.Count
    Set pt = ActiveSheet.PivotTables("Overview")
    pt.PivotCache.Refresh
    ' change field as needed

    Set pf = pt.PivotFields("Kostenstelle")

    '' Zähler initialisieren
    i = 0

    For Each pi In pf.PivotItems
       i = i + 1
       ReDim Preserve namenArray(0 To i)
       namenArray(i - 1) = pi
    Next pi

    For A = 1 To i
    
        pf.VisibleItemsList = Array(pf.PivotItems(A))
                 
        Call CopyArea
        CreateNewSheet (Range("B15").Value)
        
        pf.VisibleItemsList = namenArray
        
    Next A
   
    pf.ClearAllFilters

   Call Save
   
   Worksheets("Overview").Select
   
    Application.ScreenUpdating = True
End Sub

Sub CopyArea()
    Dim startAreaNumber, endAreaNumber As Integer
    Dim copyrangeFrom, copyrangeTo As Range
    
    Worksheets("Overview").Select
    startAreaNumber = Application.Match("Kostenstelle", Range("A:A"), 0) + 1
    endAreaNumber = Application.Match("Grand Total", Range("A:A"), 0) - 1
    
    Worksheets("User file generator").Range("A19:Q200").Value = ""
    
    Set copyrangeFrom = Worksheets("Overview").Range("A" & startAreaNumber & ":Q" & endAreaNumber)
    Set copyrangTo = Worksheets("User file generator").Range("A18:Q" & (18 + endAreaNumber - startAreaNumber))
    
    copyrangTo.Value = copyrangeFrom.Value
    
    Worksheets("User file generator").ListObjects("GeneratorTable").Resize Range("A17:P" & (18 + endAreaNumber - startAreaNumber))

End Sub

Sub CreateNewSheet(name As String)

Sheets("User File generator").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
Sheets("User File generator (2)").name = name

End Sub

Sub Save() 
     Dim pfad As String
     Dim wkbMappeNeu, wbkMappeAlt As Workbook
     Dim intChoice As Integer
     Dim strPath As String

    Set wbkMappeAlt = ActiveWorkbook

    '-----------------------------------------------------------------------

    Application.FileDialog(msoFileDialogSaveAs).InitialFileName _
    = "Q:\7. Marketing Investment\01 Actual\2019\Year End\Accruals\Tracking\Anlagenliste" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "_PO List"
    
     'make the file dialog visible to the user
    intChoice = Application.FileDialog(msoFileDialogSaveAs).Show
    'determine what choice the user made
        
    If intChoice <> 0 Then
        'get the file path selected by the user
        strPath = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
    Else
        Exit Sub
    End If
     
    Set wkbMappeNeu = Workbooks.Add
     
    wkbMappeNeu.SaveAs strPath
    
    Call Mover3(wkbMappeNeu, wbkMappeAlt)
    
    'displays the result in a message box
    Call MsgBox("Datei erfolgreich gespeichert unter: " & strPath, vbInformation, "Save Path")
    wkbMappeNeu.Save
    ActiveWorkbook.Close
 End Sub
 
 Sub Mover3(ByRef wkbMappeNeu, ByRef wbkMappeAlt)
   Dim BkNameOld, BkNameNew As String
   Dim NumSht As Integer
   Dim BegSht As Integer
   Dim TotSht As Integer

   TotSht = wbkMappeAlt.Sheets.Count
   
   BegSht = ctSheet + 1

    For x = BegSht To TotSht
  
         wbkMappeAlt.Sheets(BegSht).Move After:=wkbMappeNeu.Sheets(wkbMappeNeu.Sheets.Count)
    Next

    Application.DisplayAlerts = False
    wkbMappeNeu.Sheets("Sheet1").Delete
    wkbMappeNeu.Sheets(1).Select
    Application.DisplayAlerts = True
End Sub

I hope someone can help me.

Thank you in advance.

[Bob Phillips]

Can you post the workbook, should be simple with something to work on.

[Paul_Hossler]

Personally, I'd start with ...

    ActiveSheet.PivotTables("PivotTable1").ShowPages PageField:="AAA"

... as the core VBA which generates a filtered PT on a separate WS for each visible value of the page field

You'd need to delete any existing worksheets first and format the results afterwards but that's easy


Capture.JPG

[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