Thema Datum  Von Nutzer Rating
Antwort
Rot VBA Pivotspalte nach jedem Wert filtern und kopieren
12.01.2022 15:24:08 Albert
NotSolved

Ansicht des Beitrags:
Von:
Albert
Datum:
12.01.2022 15:24:08
Views:
47
Rating: Antwort:
  Ja
Thema:
VBA Pivotspalte nach jedem Wert filtern und kopieren

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot VBA Pivotspalte nach jedem Wert filtern und kopieren
12.01.2022 15:24:08 Albert
NotSolved