pivottabellennamen dynamisch ändern

Sub Pivotnames_change()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsList As Worksheet
Dim pt As PivotTable
Dim lPT As Long
On Error Resume Next
Set wb = ActiveWorkbook
Set wsList = Worksheets.Add
With wsList
.Range(.Cells(1, 1), .Cells(1, 4)).Value _
= Array("Sheet", "PivotTable", "Source Data", "New Names")
End With
lPT = 2
For Each ws In wb.Worksheets
For Each pt In ws.PivotTables
With wsList
.Range(.Cells(lPT, 1), .Cells(lPT, 3)).Value _
= Array(ws.Name, pt.Name, pt.SourceData)
End With
lPT = lPT + 1
Next pt
Next ws
With wsList
.Columns("A:C").EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
MsgBox "now enter the new pwt table names in column New Names"
For Each ws In wb.Worksheets
For Each pt In ws.PivotTables
pt.Name = Columns("D")
Next pt
Next ws
End Sub