Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Pivot Tabelle auswählen, kopieren, speichern

Pivot Tabelle auswählen, kopieren, speichern
09.02.2018 13:45:55
Michaela
Hallo zusammen,
ich versuche mir gerade mit VBA vertraut zu machen, bekomme aber zwischendurch immer schon Arbeitsaufträge, die meine Fähigkeiten übersteigen.
Aktuell geht es darum, dass es eine Datei mit Rohdaten und einer zugehörigen Pivot-Tabelle gibt. Die Pivot-Tabelle hat einen Bereichsfilter mit Kundenbezeichnungen. Das Makro soll bitte nacheinander jeden einzelnen Kunden im Bereichsfilter der Pivottabelle auswählen und die aktualisierte Pivottabelle in eine neue Datei kopieren. Dort dann noch mal kopieren und Werte einfügen und dann die neue Datei speichern und schließen. Dann den nächsten Kunden auswählen und alles wiederholen, bis alle im Berichtsfilter verfügbaren Kunden abgearbeitet sind.
In einem dritten Tabellenblatt namens "Grossoauswahl" habe ich in Spalte A ab Zelle A1 die Kundennamen aufgelistet, die im Berichtsfilter zur Verfügung stehen. Und in der Spalte daneben stehen Kundennummern, die ich gern als Dateinamen für die zu speichernden neuen Dateien hernehmen würde.
Unerfahren wie ich bin, habe ich erst mal ein Makro aufgezeichnet:
Sub PivotKopieren()
' PivotKopieren Makro
Sheets("Pivot").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Kunde Pivot"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("Kunde Pivot").CurrentPage _
= "1007 001 PDG BIELEFELD"
Sheets("Pivot").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"T:\dpv\Services_und_Systeme\Marktanalyse\Mitarbeiter\Scheew\Excel Makros\1007001.xlsx"  _
_
_
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub

Leider habe ich es nicht geschafft, den gewünschten Wert für den Berichtsfilter aus meinem Blatt "Grossoauswahl" in den Berichtsfilter zu kopieren. Er lässt mich dort gar nichts einkopieren.
Genausowenig konnte ich die Zelle mit dem Dateinamen kopieren und dann beim Speichern einkopieren.
Und natürlich habe ich auch noch keine Schleife, die dafür sorgt, dass der Vorgang wiederholt wird.
Und ganz zuletzt ist es noch so, dass beim Werte einfügen immer die Formatierungen der Pivot-Tabelle verschwinden.
Es wäre toll, wenn mir jemand auf die Sprünge helfen könnte, da der Wunsch nach so einem Makro in meiner Firma immer öfter und dringlicher an mich herangetragen wird.
Liebe Grüße,
Michaela
PS: Gibt es eigentlich irgendwo eine Übersicht, welche Schlüsselwörter es im Excel-VBA alles gibt? Bis jetzt habe ich nur Aufzählungen gefunden, die aber leider keine Erläuterung bieten. Ich tappe im Dunkeln.

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Pivot Tabelle auswählen, kopieren, speichern
10.02.2018 19:53:12
Dieter
Hallo Michaela,
lade doch mal eine Beispielmappe hoch. Daten beliebig verändert und/oder anonymisiert.
Stell dann den Tread wieder auf offen.
Viele Grüße
Dieter
AW: Pivot Tabelle auswählen, kopieren, speichern
13.02.2018 10:10:33
Michaela
Um es etwas ersichtlicher zu machen, habe ich jetzt die Datei hier hochgeladen:
https://www.herber.de/bbs/user/119753.xlsm
Das Makro habe ich auch noch ein kleines bischen verändert:
Sub PivotKopieren()
' PivotKopieren Makro
Sheets("Pivot").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Kunde Pivot"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("Kunde Pivot").CurrentPage _
= "1007 001 PDG BIELEFELD"
Sheets("Pivot").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\schee8\Desktop\Test\Makro\1007001.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub
Die Fragestellung ist noch immer die gleiche, wie im Ursprungspost.
Danke und Grüße,
Michaela
Anzeige
AW: Pivot Tabelle auswählen, kopieren, speichern
13.02.2018 22:53:04
Dieter
Hallo Michaela,
ich hab deine Anforderungen noch nicht ganz verstanden, aber als Diskussionsgrundlage habe ich dir mal das folgende Programm in deine Mappe eingefügt:
Sub Kopieren()
Dim dateiName As String
Dim pf As PivotField
Dim pfad As String
Dim pi As PivotItem
Dim pii As PivotItem
Dim piAkt As PivotItem
Dim pt As PivotTable
Dim wb As Workbook
Dim wbK As Workbook
Dim wsP As Worksheet
Application.ScreenUpdating = False
Set wb = ThisWorkbook
pfad = ThisWorkbook.Path & "\"
Set wsP = wb.Worksheets("Pivot")
Set pt = wsP.PivotTables(1)
Set pf = pt.PivotFields("Kunde Pivot")
pf.EnableMultiplePageItems = True
For Each pi In pf.PivotItems
If Item_aufgelistet(pi) Then
Set piAkt = pi
For Each pii In pf.PivotItems
On Error Resume Next
pii.Visible = False
On Error GoTo 0
Next pii
piAkt.Visible = True
dateiName = Replace(Left$(pi.Name, 8), " ", "") & ".xlsx"
Application.StatusBar = "Verarbeitung von """ & dateiName & """"
wsP.Copy
Set wbK = ActiveWorkbook
Application.DisplayAlerts = False
On Error Resume Next
Workbooks(dateiName).Close SaveChanges:=False
On Error GoTo 0
wbK.SaveAs Filename:=pfad & dateiName
Application.DisplayAlerts = True
wbK.Close
End If
Next pi
' Alle PivotItems anzeigen
For Each pi In pf.PivotItems
On Error Resume Next
pi.Visible = True
On Error GoTo 0
Next pi
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Function Item_aufgelistet(pivItem As PivotItem) As Boolean
Item_aufgelistet = True
On Error GoTo Fehler
pivItem.Visible = True
Exit Function
Fehler:
Item_aufgelistet = False
End Function
Viele Grüße
Dieter
https://www.herber.de/bbs/user/119781.xlsm
Anzeige
AW: Pivot Tabelle auswählen, kopieren, speichern
15.02.2018 13:10:59
Michaela
Lieber Dieter,
das ist total super!! Ich glaube, Du hast mich sogar sehr gut verstanden!
Das einzige was ich noch bräuchte ist, dass vor dem Speichern der jeweils neuen Datei noch mal alle Inhalte kopiert und als Werte eingefügt werden müssten. Die Tabellen sollen nachher an Kunden geschickt werden und die sollen weder Probleme mit Bezügen haben, noch dürfen sie die Daten anderer Kunden sehen.
Liebe Grüße,
Michaela
AW: Pivot Tabelle auswählen, kopieren, speichern
15.02.2018 13:11:59
Michaela
x
AW: Pivot Tabelle auswählen, kopieren, speichern
16.02.2018 20:48:50
Dieter
Hallo Michaela,
dann könnte das so aussehen:
Sub Kopieren()
Dim anzDateien As Long
Dim dateiName As String
Dim letzteZeile As Long
Dim pf As PivotField
Dim pfad As String
Dim pi As PivotItem
Dim pii As PivotItem
Dim piAkt As PivotItem
Dim pt As PivotTable
Dim rngPiv As Range
Dim wb As Workbook
Dim wbK As Workbook
Dim ws As Worksheet
Dim wsP As Worksheet
Application.ScreenUpdating = False
Set wb = ThisWorkbook
pfad = ThisWorkbook.Path & "\"
Set wsP = wb.Worksheets("Pivot")
Set pt = wsP.PivotTables(1)
Set pf = pt.PivotFields("Kunde Pivot")
pf.EnableMultiplePageItems = True
For Each pi In pf.PivotItems
If Item_aufgelistet(pi) Then
Set piAkt = pi
For Each pii In pf.PivotItems
On Error Resume Next
pii.Visible = False
On Error GoTo 0
Next pii
piAkt.Visible = True
dateiName = Replace(Left$(pi.Name, 8), " ", "") & ".xlsx"
Application.StatusBar = "Verarbeitung von """ & dateiName & """"
wsP.Copy
Set wbK = ActiveWorkbook
' PivotTable durch Werte ersetzen
Set ws = wbK.Worksheets(1)
Set pt = ws.PivotTables(1)
Set rngPiv = pt.TableRange2
letzteZeile = rngPiv.Rows.Count
rngPiv.Copy
ws.Cells(letzteZeile + 1, "A").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = xlCut
ws.Range(ws.Rows(1), _
ws.Rows(letzteZeile)).Delete
ws.Range("A1").Select
' Arbeitsmappe speichern
Application.DisplayAlerts = False
On Error Resume Next
Workbooks(dateiName).Close SaveChanges:=False
On Error GoTo 0
wbK.SaveAs Filename:=pfad & dateiName
anzDateien = anzDateien + 1
Application.DisplayAlerts = True
wbK.Close
End If
Next pi
' Alle PivotItems anzeigen
For Each pi In pf.PivotItems
On Error Resume Next
pi.Visible = True
On Error GoTo 0
Next pi
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox anzDateien & " Dateien im Verzeichnis" & vbNewLine & _
pfad & vbNewLine & "erstellt."
End Sub
Function Item_aufgelistet(pivItem As PivotItem) As Boolean
Item_aufgelistet = True
On Error GoTo Fehler
pivItem.Visible = True
Exit Function
Fehler:
Item_aufgelistet = False
End Function
Viele Grüße
Dieter
https://www.herber.de/bbs/user/119862.xlsm
Anzeige

10 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige