AW: pivottabellennamen dynamisch ändern
08.07.2014 15:30:14
fcs
Hallo Hewad,
das Ganze funktioniert nur wenn du Makro "Pivotnames_change_mit_UF", dann in der Liste die neuen Namen einträgst (du kannst auch für eine Pivot-Tab den alten Namen wieder verwenden), und wenn alles fertig ist klickst du auf die Schaltfläche im Userform. Du darfst das Userform in der Zwischenzeit nicht schließen!
Wenn du die Liste mit den neuen Namen (bei mehreren 100 Pivottabellen verständlich) in mehreren Etappen eintragen willst, dann muss das Erstellen der Liste mit Namen der Pivottabellen und das Umbenennen in 2 getrennten Makros erfolgen. Man muss dann nur darauf achten, dass das Umbenennmakro auf das richtige Tabellenblatt zugreift.
Gruß
Franz
Makros in einem allgemeinen Modul
'Dieses Makro starten, um in einem zusätzlichen Tabellenblatt die Liste _
der Namen der Pivottabellen in der Arbeitsmappe anzulegen.
Sub Pivotnames_change_Liste_anlegen()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsList As Worksheet
Dim pt As PivotTable
Dim strNewName As Variant
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
Range("A2").Select
ActiveWindow.FreezePanes = True
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
End Sub
'Dieses Makro starten, wenn in der Spalte "New Names" alle Zellen ausgefüllt sind.
Sub Pivotnames_change_neue_Namen()
Dim wb As Workbook, ws As Object
Dim wsList As Worksheet
Dim pt As PivotTable
Dim strNewName As Variant
Dim lPT As Long, bolCheck As Boolean
Set wsList = ActiveSheet
Set wb = wsList.Parent
With wsList
If Not (.Cells(1, 2).Value = "PivotTable" _
And .Cells(1, 3).Value = "Source Data" _
And .Cells(1, 4).Value = "New Names") Then
MsgBox "Das aktive Tabellenblatt enthält keine Liste mit neuen " _
& "Pivot-Tabellennamen!", , "Pivot-Tabellen umbenennen"
Exit Sub
End If
.Columns("D:D").EntireColumn.AutoFit
.Columns("E:E").ClearContents
Select Case MsgBox("Alle neuen Pivot-Tabellennamen im aktiven Tabellenblatt ok?" _
& vbLf & vbLf _
& "Ja = Pivot-Tabellen werden umbenannt" & vbLf _
& "Nein = Neue Namen werden nochmals abgefragt" & vbLf _
& "Abbrechen = Pivottabellen werden nicht umbenannt", _
vbQuestion + vbYesNoCancel, _
"Neue Namen Pivot-Tabellen")
Case vbYes
'Prüfen, ob Leere Zellen als neue Namen vorkommen
bolCheck = False
For lPT = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(lPT, 4).Text = "" Then
.Cells(lPT, 5).Value = "Leerzelle als neuer Name nicht zulässig"
bolCheck = True
End If
Next lPT
If bolCheck = True Then
MsgBox "Leerzellen sind als neue Namen nicht zulässig", , _
"Pivot-Tabellen umbenennen"
Exit Sub
End If
'Prüfen ob neue Pivotnamen in einem Blatt doppelt vorkommen
lPT = .Cells(.Rows.Count, 1).End(xlUp).Row
If lPT > 1 Then
With .Range(.Cells(2, 5), .Cells(lPT, 5))
.FormulaR1C1 = _
"=SUMPRODUCT((R2C1:R" & lPT & "C1=RC[-4]) * (R2C4:R" & lPT & "C4=RC[-1]))"
.Value = .Value
If Application.WorksheetFunction.CountIf(.Cells, ">1") > 0 Then
For lPT = 1 To .Rows.Count
If .Cells(lPT, 1).Value = 1 Then
.Cells(lPT, 1).ClearContents
End If
Next
MsgBox "Es gibt doppelte Namen von Pivottabellen" & vbLf _
& "(in Spalte E mit Werten 2 oder größer gekennzeichnet)", , _
"Pivot-Tabellen umbenennen"
Exit Sub
Else
.Clear
End If
End With
End If
bolCheck = False
'Pivottabellen namen auf schon vorhandenen prüfen
For lPT = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set ws = wb.Sheets(.Cells(lPT, 1).Text)
Set pt = ws.PivotTables(.Cells(lPT, 2).Text)
If fncCheckname(ws, strNamePT:=.Cells(lPT, 4).Text, pvTab:=pt, _
bolMsg:=False) = False Then
.Cells(lPT, 5).Value = "Name in Zeile " & lPT _
& " schon für andere Pivot-Tabelle im Tabellenblatt vorhanden"
bolCheck = True
End If
Next lPT
If bolCheck = True Then
MsgBox "Neue Namen werden für eine andere Pivottabelle verwendet"
Exit Sub
End If
'Pivottabellen umbenennen
For lPT = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set ws = wb.Sheets(.Cells(lPT, 1).Text)
Set pt = ws.PivotTables(.Cells(lPT, 2).Text)
pt.Name = .Cells(lPT, 4).Text
Next lPT
MsgBox "Pivot-Tabellen sind umbenannt"
Case vbNo
Exit Sub
Case vbCancel
'Abbrechen
End Select
End With
End Sub
Function fncCheckname(ws As Worksheet, ByVal strNamePT As String, _
pvTab As PivotTable, Optional bolMsg As Boolean = True) As Boolean
'Prüft ob der eingegebene neue Name schon für eine andere Pivot-Tabelle _
im Blatt existiert.
Dim pvT As PivotTable
If strNamePT = "" Then
If bolMsg = True Then MsgBox "Leerstring ist als Name nicht zulässig!"
Exit Function
End If
fncCheckname = True
For Each pvT In ws.PivotTables
If Not LCase(pvT.Name) = LCase(pvTab.Name) Then
If LCase(pvT.Name) = LCase(strNamePT) Then
If bolMsg = True Then
MsgBox "Der eingegebene Name exitiert schon für eine andere " _
& "Pivot-Tabelle im Blatt", , _
"Prüfung Name Pivot-Tabelle"
End If
fncCheckname = False
Exit Function
End If
End If
Next
End Function