Pivot filter by each item and copy to new sheet

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)

Code:

---

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.

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

Personally, I'd start with ...

Code:

---

    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


Attachment 29304

Something like this

Code:

---

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

---