Seitenfeldber. autom. on Pivotupdate anpassen

Hallo Herber Fans,
ich habe beim intensiven Arbeiten mit Pivottabellen bemerkt, daß der Seitenfeldbereich sich immer nach oben verschiebt, wenn ihm ein Elemente aus dem bspw. Zeilenbereich hinzugefügt wird. Wenn über dem Zeilenbereich die Zellen mit erläuterndem Text gefüllt sind und der Seitenfeldbereich sich darüber schiebt, kommt eine Warnmeldung und es besteht lediglich die Option, die Veränderung der Pivot zu unterlassen oder aber ein Überschreiben des Textes in der angrenzenden Zelle hinzunehmen.
Aus diesem Grund stelle ich mir die Frage, ob es möglich ist, in der Pivot eine Eigenschaft zu hinterlegen, damit dies unterbleibt und der Seitenfeldbereich, respektive die ganze Pivot sich nur nach unten bewegt.
Da ich vermute, daß es eine solche Option nicht gibt, habe ich angefangen an einem Makro zu arbeiten. Es funktioniert auch soweit. Ich kann feststellen, welches die ersten Zeile des Seitenfeldbereiches ist und möchte dann wieder eine Zeile einfügen, damit zwischen Seitenfeldbereich und der gefüllten Zelle darüber wieder eine Zeile Abstand ist.
Das Einfügen den Zellen funktioniert aber nicht direkt. Ich bekomme die Meldung, daß ich den Pivottable Bericht nicht in dieser Form verändern darf. Also müßte ich eine Zeile weiter oben eine Zeile einfügen und den Inhalt übertragen und dann das Format löschen.
Gibt es keinen direkteren Weg?
Ziel soll sein, daß immer eine Zeile über dem Seitenfeldbereich frei ist.
https://www.herber.de/bbs/user/52999.xls
Vielen Dank für Eure Ideen und Anregungen.
Grüße, Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub PivotVerschieben(objPT As PivotTable, Optional bolUnten As Boolean = True) 'Verschiebt Pivottabelle 1 Zeile nach unten/oben Dim strZelle As String With objPT.TableRange2 strZelle = .Range("A1").Address .Cut Destination:=Range(strZelle).Offset(IIf(bolUnten = True, 1, -1), 0) End With End Sub Sub PivotMakro() 'Verschiebt Pivottabelle Application.ScreenUpdating = False '1 nach unten Call PivotVerschieben(objPT:=ActiveSheet.PivotTables(1), bolUnten:=True) '1 nach oben Call PivotVerschieben(objPT:=ActiveSheet.PivotTables(1), bolUnten:=False) Application.ScreenUpdating = True End Sub

'Tabellen-Modul '### obere Positon des Pivot-Berichtes 1 einfrieren, Text oberhalb konservieren ### 'Ersteller: fcs 'Erstellt: 2008-06-12 'Modifiziert: 2008-06-12 'Excelversion: 2003 - SP2 Private objPT_Range As Range 'Variable zum Merken des Pivottabellenbereichs Private arrOberhalb() As Variant 'Variable zum Merken des Textes in den Zellen oberhalb Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable) On Error GoTo Fehler Application.EnableEvents = False If Not objPT_Range Is Nothing Then If Target.TableRange2.Row - objPT_Range.Row = -1 Then '1 Seitenfeld wurde eingefügt, Pivot-Bericht 1 Zeile nach oben verschoben Call PivotVerschieben(objPT:=Target, lngZeilen:=1) If Target.TableRange2.Row > 1 Then 'Inhalte oberhalb Pivot-Bereicht wieder einfügen For intI = 1 To UBound(arrOberhalb) Target.TableRange2.Range("A1").Offset(-1, intI - 1).Value = arrOberhalb(intI) Next End If ElseIf Target.TableRange2.Row - objPT_Range.Row = -2 Then '1. Seitenfeld wurde eingefügt -Pivot kann sich um 2 Zeilen nach oben verschieben Call PivotVerschieben(objPT:=Target, lngZeilen:=2) If UBound(arrOberhalb) > 0 Then 'Inhalte oberhalb Pivot-Bereicht wieder einfügen For intI = 1 To UBound(arrOberhalb) Target.TableRange2.Range("A1").Offset(-1, intI - 1).Value = arrOberhalb(intI) Next Target.TableRange2.Range("A1").Offset(1, 0).EntireRow.ClearContents End If ElseIf Target.TableRange2.Row - objPT_Range.Row > 0 Then '1 Seitenfeld wurde gelöscht Call PivotVerschieben(objPT:=Target, lngZeilen:=-1) If Target.PageFields.Count = 0 Then 'wenn keine Seitenfelder mehr, dann noch eine Zeile hoch Call PivotVerschieben(objPT:=Target, lngZeilen:=-1) End If End If Set objPT = Target.TableRange2 End If Fehler: If Err.Number 0 Then MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description End If Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim intI As Integer 'Aktuellen Bereich der Pivottabelle 1 merken Set objPT_Range = Me.PivotTables(1).TableRange2 If objPT_Range.Row > 1 Then 'Zellinhalte in Zeile oberhalb Pivottablle in Array merken ReDim arrOberhalb(1 To Application.WorksheetFunction.Max(1, objPT_Range.Column _ - Cells(objPT_Range.Row - 1, Me.Columns.Count).End(xlToLeft).Column) + 1) For intI = 1 To UBound(arrOberhalb) arrOberhalb(intI) = objPT_Range.Range("A1").Offset(-1, intI - 1).Value Next Else ReDim arrOberhalb(0) End If End Sub 'Allgemeines-Modul Position des Pivot-Berichtes um x Zeilen verschieben 'Ersteller: fcs 'Erstellt: 2008-06-11 'Modifiziert: 'Excelversion: 2003 - SP2 Sub PivotVerschieben(objPT As PivotTable, Optional lngZeilen As Long = 1) 'Verschiebt Pivottabelle um lngZeilen nach unten/oben Dim strZelle As String With objPT.TableRange2 strZelle = .Range("A1").Address .Cut Destination:=Range(strZelle).Offset(lngZeilen, 0) End With End Sub

Hallo Franz,
vielen Dank für Deine Hartnäckigkeit in dieser Angelegenheit. Ich habe Deinen Code eingesetzt und getestet. Wie kaum anders zu erwarten läuft er einwandfrei durch. Eine geniale Leistung, daß es auch mit einer, bzw. gar keiner (!) Zeile Abstand klappt. Und das die Fehlermeldung kommt, wenn der Text direkt angrenzt ist marginal, zumal der Text ja auch wieder einwandfrei hergestellt wird.
Insgesamt ist mir schleierhaft, warum man in einer Pivot nicht einfach eine Startzelle fest hinterlegen kann und das so ein Aufwand getrieben werden muß, eine Pivot zu fixieren. Aber das ist vermutlich eine der Mysterien der Microsoft Programmierung.
Ich habe am Wochenende auch noch ein wenig probiert da es mir keine Ruhe gelassen hat. Als Kompromiß habe ich mir jedoch erlaubt, zwei Zeilen über dem PageRange vorzusehen. Das macht die Sache nicht ganz so komplex. Ich habe schon einen Code erstellt, dessen einzelne Komponenten (einmal die Situation, daß Text vor der Pivot vorhanden ist und einmal nicht) schon gelaufen sind. Aber ich bekomme Sie nicht kombiniert. Zur Prüfung ob Text vorhanden ist oder nicht verwende ich eine Application.CountIf Funktion, mit der es aber offensichtlich Probleme gibt. Sie funktioniert nur einmal und liefert dann falsche Ergebnisse.
Ich habe die grundlegende Syntax einmal in Worten aufgeschrieben, der Code ist schon in der Datei:

# # # START
Prüfe die Position der ersten PageRange Zeile.
Wenn > 1, dann prüfe, ob Text in den Zeilen davor steht. Wenn ja, dann prüfe, ob mindestens zwei Zeilen Platz sind, um eine Zeile ohne Pivot Fehlermeldung einfügen zu können. Wenn Nein: Messagebox die darauf hinweist und fragt, ob der Text ignoriert und gelöscht werden soll, um die Pivot hoch zu rücken. Wenn genug Platz ist, dann soll die Pivot bis zwei Zeilen unter den Text gerückt werden. Sind mehr als zwei Zeilen Platz, sollen überschüssige Zeilen gelöscht werden.
Wenn kein Text vorhanden ist, sollen alle Zeilen über der Pivot gelöscht werden.
Anschließend komplett neue Gruppierung. Entweder nur der PageRange oder der PageRange + die zwei Zeilen darüber (wenn Text vorhanden war). Damit die Gruppierung nicht wuchert, wird vor dem Code mit einem Errorhandling jedwede Gruppierung entfernt.
# # # ENDE

https://www.herber.de/bbs/user/53118.xls
Kannst Du mir sagen, wo der Fehler in der Application.CountIf Funktion liegt? Bzw. was ist der effizienteste und sicherste Weg in VBA, um einen Range bzgl. Leerer Zellen (alle Leer oder nicht) zu prüfen. Denn wenn diese Prüfung korrekt funktioniert müßte der Code durchlaufen und alle vorkommenden Konstellationen ohne Fehler bearbeiten können.
Dann glaube ich ist meine Neugier in Sachen PivotFixierung auch gestillt und ich werde es in die Überwachung durch ein Klassenmodul einfügen und so praktisch testen. Aber ich denke, Dein Code ist schon das Ausgereifteste was es gibt.
Vielen Dank und Grüße, Andreas

Function AlleZellenLeer1(rng As Range) As Boolean On Error GoTo Fehler If rng.Cells.SpecialCells(xlCellTypeBlanks).Count = rng.Cells.Count Then AlleZellenLeer1 = True End If Fehler: If Err.Number 0 Then If Err.Number = 1004 Then AlleZellenLeer1 = False Else MsgBox Err.Number & vbLf & Err.Description AlleZellenLeer = False End If End If End Function

Function AlleZellenLeer2(rng As Range) As Boolean Dim objZelle As Range For Each objZelle In rng AlleZellenLeer2 = IsEmpty(objZelle) If IsEmpty(objZelle) = False Then Exit For Next Set objZelle = Nothing End Function

Sub Katzi() 'Läuft gut durch!!! ' Sub arrTest(rngInput As Range) 'As String Dim rngInput As Range 'Set rngInput = Tabelle1.Range(Cells(3, 1), Cells(1, 1)) Set rngInput = Selection If Application.CountIf(rngInput, "") = rngInput.Cells.Count Then 'arrTest = "alles OK" MsgBox "Kein Text" Else 'arrTest = "Nicht erlaubte Werte" MsgBox "Text vorhanden" End If Set rngInput = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Seitenfeldber. autom. on Pivotupdate anpassen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Seitenfeldber. autom. on Pivotupdate anpassen

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

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread