Hallo,
ich bin neu im Forum und habe ein Problem mit der SourceData-Methode zur automatischen Anpassung der Pivot-Quellbezüge. Die vielen Beiträge zu diesem Thema haben mit bisher leider nicht weiter geholfen.
Ziel:
Durch aktivieren eines Buttons soll ein Formular geöffnet werden, in dem eine Projektnummer und eine Projektbezeichnung eingegeben werden können (funktioniert). Durch Bestätigung des Buttons mit ok wird eine Pivottabelle (Vorlage, Zeile 3:1002) kopiert und unterhalb der letzen genutzten Zelle neu eingefügt (funktioniert). Anschließend soll der Pivotbezug mit der neuen Projektbezeichnung (=Name der Quelldatei) aktualisiert werden. Dies funktioniert nicht.
Code:
Private Sub Button_OK_Click()
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
'Schließt alle Gruppierungen
If Pnr = "" Then MsgBox "Projektnummer fehlt!": Exit Sub
If Pbez = "" Then MsgBox "Projektbezeichnung fehlt!": Exit Sub
'Eingabe der Projektnummer und Projektbezeichnung in Formular. Messagebox erscheint bei fehlender Eingabe.
Dim Ende As Long
With ActiveSheet
Ende = .Cells(Rows.Count, 1).End(xlUp).Row
End With
'Ermittelt letze Zelle
Rows("3:1002").Select
Selection.Copy
'Makierert und Kopiert Vorlage (Zeile 3 = sichtbar, Zeile 4-1002 (Gruppierung) nicht sichtbar)
Rows(Ende + 1000).Select
ActiveSheet.Paste
'Fügt die Vorlage-Pivottabelle an unterster Stelle neu ein
Cells(Ende + 1000, 1).Value = PDefinition.Text
Cells(Ende + 1000, 2).Value = StTabBEZ.Text
' Schreibt PNr in Zelle A1003 und PBez in Zelle B1003 (Überschriftszeile)
' (Pivottabelle befindet sich in Zelle A1004ff.)
'*******************************************************************************
'FEHLERHAFTER CODE (Ändert die Datenquelle der neu erstellten Pivot-Tabelle):
Cells(Ende + 1001, 1).Select
Dim PT As PivotTable
On Error Resume Next
Set PT = ActiveCell.PivotTable
On Error GoTo 0
If Not PT Is Nothing Then
On Error GoTo ErrMsg 'NEU
'funktioniert nicht
PT.ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"'\\XYZ\Gruppenlaufwerk\Projekte\[" & (Pbez) & ".xlsm]Datentabelle!R5C1:R2000C57" _
, Version:=xlPivotTableVersion10)
'die Kombination aus SourceData und der Variable (Pbez) funktioniert nicht. Es erscheint die untenstehende Fehlermeldung
MsgBox "'\\XYZ\Gruppenlaufwerk\Projekte\[" & (Pbez) & ".xlsm]Datentabelle!R5C1:R2000C57"
' Messagebox zeigt als Information den neuen Quellbezug. Dieser stimmt theoretisch.
'Alternativer/Fixer Code: (fuktioniert)
' PT.ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"'\\XYZ\Gruppenlaufwerk\Projekte\[2018_Projekt_1.xlsm]Datentabelle!R5C1:R2000C57" _
, Version:=xlPivotTableVersion10)
End If
'*******************************************************************************
Unload Me 'schließt das Eingabefenster
Cells(Ende + 1000, 1).Select
Application.CutCopyMode = False
Exit Sub
ErrMsg:
MsgBox "Das hat leider nicht funktioniert. Bitte ändern Sie die Pivotdatenquelle manuell!", , "UNBEKANNTER FEHLER!" 'Zeigt Fehlermeldung
Unload Me 'schließt das Eingabefenster
Cells(Ende + 1000, 1).Select
Application.CutCopyMode = False
____
Vielen Dank für Eure Hilfe!