Hallo Zusammen,

ich habe eine Makro, die eine Pivot "Overview" nach der Spalte Kostenstelle filtern soll und dann das gefilterte in ein neues Sheet kopiert. Das soll mit jeder Kostenstelle so passieren.

ich bekomme allerdings einen Fehler: Application defined or object defined error.

Ich wäre sehr dankbar, wenn mir jemand helfen kann.

Das ist mein 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