Alte Pivot Darstellung
18.07.2017 16:37:12
Lena
ich habe mir alles selbst beigebracht, daher bitte gnädig sein.
Ich habe folgendes Problem. Ich habe einen VBA geschrieben, der meine Datengrundlage zunächst nach Division (Div) und dann nach Country (CTY) filtert und die Daten in ein neues Worksheet bringt. Dann kopiere ich dieses Worksheet und ein schön aufbereitetes Worksheet (mit einer Pivot und Slicern) in ein eigenes Workbook. Das läuft alles im Loop und funktioniert soweit.
Ich würde nur gerne die Pivot mit der neuen Datenbasis aktualisieren. Hier habe ich mir die Zähne ausgebissen, die Datenquelle zu ändern...
Daher dachte ich, dass ich einen anderen Weg probiere und eine neue Pivot aufbaue. Sollte ja auch eigentlich der einfachste Weg sein... Leider erhalte ich immer die alte Version von der Pivot (obwohl ich die neueste Version nutze und die Datei als xlsx abspeichere). Diese kann ich nur leider nicht nutzen, wenn ich Datenschnitte verwenden möchte. Ich habe daher beim pivot cache und der Erstellung der Pivot darauf geachtet Version:=xlPivotTableVersion15 einzufügen. Da erhalte ich nur leider einen Fehler... ich bin hier ziemlich ratlos und alles was ich dazu gelesen habe, hat mich nicht weiter gebracht...
Ich hoffe ihr könnt helfen.
Hier der Code:
Sub DIVCTYbu()
Sheets("Country Report Generator").Select
Div_Count = Cells(65536, 1).End(xlUp).Row
'Divisional Loop
Sheets("Country Report Generator").Select
For A = 2 To Div_Count
Sheets("Country Report Generator").Select
Div = Cells(A, 1).Value
'Definition
Sheets("Original Data from SAP").Select
lr = Cells(65536, 1).End(xlUp).Row
lc = Cells(1, 255).End(xlToLeft).Column
'Create new worksheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "raw data"
'Filters for a division, copies and pastes into Worksheet Country Report
Sheets("Original Data from SAP").Select
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=33, Criteria1:=Div
'Copy and paste and set filter
Range(Cells(1, 1), Cells(lr, lc)).Select
Selection.Copy
Sheets("raw data").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=33
'Reset Filter
Sheets("Original Data from SAP").Select
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=33
'COUNTRY LOOP
Sheets("Country Report Generator").Select
Cty_Count = Cells(65536, 2).End(xlUp).Row
For B = 2 To Cty_Count
Sheets("Country Report Generator").Select
CTY = Cells(B, 2).Value
'Definition
Sheets("raw data").Select
lr = Cells(65536, 1).End(xlUp).Row
lc = Cells(1, 255).End(xlToLeft).Column
'Create Country Report
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Country Report"
'Filters for a country, copies and pastes into Worksheet Country Report
Sheets("raw data").Select
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=2, Criteria1:= _
_
_
CTY
'Copy and paste and set filter
Range(Cells(1, 1), Cells(lr, lc)).Select
Selection.Copy
Sheets("Country Report").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=2
'Reset Filter
Sheets("raw data").Select
ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).AutoFilter Field:=2
'New Workbook for Country Report
File_Path = ThisWorkbook.Path 'Saves current file path
'Current Date
Dim szTodayDate As String
szTodayDate = Format(Date, "yyyyMMDD")
'Copy
Worksheets(Array("Country Report", "Pivot Master_Division")).Copy
Application.DisplayAlerts = False 'shut off warning message
'Set curser on cell A1
ActiveSheet.Cells(1, 1).Select
'Save as
ActiveWorkbook.SaveAs Filename:="" & File_Path & "\" & szTodayDate & "_" & Div & "_" & _
_
_
CTY & "_" & ("Open Order Report") & ".xlsx", FileFormat:=51, CreateBackup:=False
'Rename Worksheet
Sheets("Pivot Master_Division").Name = "Overview"
Sheets("Country Report").Name = "raw data"
'Create new worksheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Overview 2"
'Ordnung muss sein
Sheets("Overview 2").Select
With ActiveWorkbook.Sheets("Overview 2").Tab
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
Sheets("raw data").Select
Sheets("raw data").Move After:=Sheets(3)
'Create Overview 2
'Definition
Sheets("raw data").Select
'definitions that have worked before
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("raw data")
Sheets("raw data").Select
Dim PTCache As PivotCache 'for pivot cache object
Dim pt As PivotTable 'for pivottable object
Dim pf1 As PivotField
Dim pf2 As PivotField
Dim pf3 As PivotField
Dim pf4 As PivotField
Dim pf5 As PivotField
Dim Prng As Range
Dim lar As Long
Dim lac As Long
Dim ar As Variant
Dim i As Integer
lar = ws.Cells(Rows.Count, 1).End(xlUp).Row
lac = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set Prng = ws.Cells(1, 1).Resize(lar, lac)
'CreatePivotTable()
'Select destination sheet
Sheets("Overview").Select
'create a pivotcache object using datasource
Set PTCache = ActiveWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=Prng, _
Version:=xlPivotTableVersion15)
Debug.Print ThisWorkbook.PivotCaches.Count
'create a pivottable at location B20 and name the pivottable as Pivot1
Set pt = PTCache.CreatePivotTable(Range("B20"), "Pivot1",Version:=xlPivotTableVersion15) _
)
ActiveWorkbook.Save
ActiveWorkbook.Close
'Sets the selected Cell to the beginning of the raw data worksheet
Sheets("raw data").Cells(1, 1).Select
'Turn off display errors
On Error GoTo DispFehler
Application.DisplayAlerts = False
'Country Report löschen
Sheets("Country Report").Select
ActiveWindow.SelectedSheets.Delete
Next B
'Delete raw data tab (because a new one will be generated for each division)
Sheets("raw data").Select
ActiveWindow.SelectedSheets.Delete
'Turn on display errors again
DispFehler:
Application.DisplayAlerts = True
Next A
MsgBox "Report Completed. Report(s) are saved in the same folder as this file. Please save this _
_
_
file with a new name. Please don't overwrite the master template! IMPORTANT: Please move the _
created files to another folder before using this makro again."
End Sub
Viele Grüße,
Lena