Microsoft Excel

Herbers Excel/VBA-Archiv

Pivottabelle in VBA | Herbers Excel-Forum


Betrifft: Pivottabelle in VBA von: David
Geschrieben am: 02.12.2009 16:24:07

Hallo an alle.

Ein großes schwarzes Loch meiner VBA-Kenntnisse betrifft Pivottabellen und wie ich gerade wieder erfahren musste, ist der Recorder diesbezüglich nicht zu gebrauchen.

Folgendes Problem:

Ich habe in einer Tabelle eine bestehende Pivottabelle. Diese greift auf eine andere Excel-Datei zu. Nun kann es vorkommen, dass der verwendete Pivotbereich nicht mehr für die Quell-Datei ausreicht und ein Bereich fehlt. Meine Idee war, jedesmal per VBA den Bereich der Pivottabelle neu festzulegen. Dies klappt allerdings nicht.

meine umgestrickte Recorder-Aufzeichnung:

With Workbooks("Verluste.xls").Sheets(1)
.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
"'\Workgroup\Fehlerbeseitigung\Produktion\[Materialabweichung komplett.xls]SAPBW_DOWNLOAD'!R1C1:R" & Zeilen & "C22"
End With

Die Variable 'Zeilen' hat den korrekten Wert. Die Quell-Datei ist während der Laufzeit geöffnet. Der Code startet innerhalb eines größeren Makros (Autorun!) fast am Ende. Beim Öffnen der Datei bleibt der Code an der Zeile hängen mit irgendeiner Fehlermeldung von wegen "verbundene Zellen". Wenn ich dann im Debug-Modus mit Einzelschritt weitergehe, läuft der Code aber weiter?!

Was ich merkwürdig finde, ist, das in der Wizard-Zeile nirgends erkennbar ist, auf welche Pivottabelle er sich bezieht. Vermutlich will er eine neue anlegen, er soll aber nur die 'alte' verändern. Gibt es noch eine andere Möglichkeit, per VBA den verwendeten Bereich einer Pivottabelle festzulegen außer über den Wizard? Ich habe jedenfalls nix gefunden.

Damit nicht wieder einer 'meckert', hier noch 'informativ' der komplette Code, absichtlich am Ende des Posts zur besseren Übersicht. ;-)

Gruß
David

Option Explicit

Private Sub Workbook_Open()

'Application.ScreenUpdating = False
    
Workbooks.Open Filename:= _
    "N:\Workgroup\Fehlerbeseitigung\Produktion\Materialabweichung komplett.xls"

If Workbooks("Materialabweichung komplett.xls").Sheets("SAPBW_DOWNLOAD").Range("A1") = " _
Materialabweichung" Then
    Call mat_abw
    Workbooks("Materialabweichung komplett.xls").Close savechanges:=True
Else
    Workbooks("Materialabweichung komplett.xls").Close savechanges:=False
End If

Application.ScreenUpdating = True

End Sub
Sub mat_abw()

GetMoreSpeed True

Dim Treffer
Dim Zeilen As Long
Dim i As Long
Dim j As Integer
Dim Spalten As Integer
Dim KW_Col As Integer
Dim meAr(), tmpAr()
Dim A As Long, AA As Long
Dim oSH As Worksheet
Dim strSuchwert As String
Dim iCalc As Integer
 
If Workbooks("Materialabweichung komplett.xls").Sheets("SAPBW_DOWNLOAD").Range("A1") = " _
Materialabweichung" Then Rows("1:34").EntireRow.Delete

'Ergebniszeilen löschen
strSuchwert = "Ergebnis"
Set oSH = Workbooks("Materialabweichung komplett.xls").Sheets("SAPBW_DOWNLOAD")
If Application.WorksheetFunction.CountIf(oSH.Cells, strSuchwert) > 0 Then
    With oSH.UsedRange
        meAr = .Value2
        ReDim Preserve tmpAr(1 To UBound(meAr))
                     
        For A = 1 To UBound(meAr)
            For AA = 1 To UBound(meAr, 2)
                If CStr(meAr(A, AA)) = strSuchwert Then
                    tmpAr(A) = "=TRUE"
                ElseIf tmpAr(A) <> "=TRUE" Then
                    tmpAr(A) = "=ROW()"
                End If
            Next AA
        Next A
                     
        With .Columns(.Columns.Count).Offset(0, 1)
            .Cells(1, 1).Resize(A).FormulaR1C1 = Application.Transpose(tmpAr)
            oSH.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
            On Error Resume Next
            .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
            On Error GoTo 0
            .EntireColumn.Delete
        End With
    End With
End If

'Leerzellen nach unten auffüllen

With Workbooks("Materialabweichung komplett.xls").Sheets(1)

Zeilen = .UsedRange.Rows.Count
If Cells(Zeilen, 1) = "Gesamtergebnis" Then
    Rows(Zeilen).EntireRow.Delete
    Zeilen = Zeilen - 1
End If

Spalten = .UsedRange.Columns.Count - 8
For i = 2 To Zeilen
    For j = 1 To Spalten
        If Cells(i, j) = "" And Not Cells(1, j) = "Kalenderjahr / Woche" Then Cells(i, j) =  _
Cells(i, j).Offset(-1, 0)
    Next
Next

'Leerzellen für Spalte 'Kalenderjahr / Woche' auffüllen
Set Treffer = Range(.UsedRange.Address).Find("Kalenderjahr / Woche")
If Not Treffer Is Nothing Then KW_Col = Treffer.Column
If KW_Col > 0 Then
    For i = 2 To Zeilen
        If Cells(i, KW_Col) = "" Then Cells(i - 1, KW_Col).Copy Destination:=Cells(i, KW_Col)
    Next
End If

'Spaltenüberschriften ergänzen
For i = 2 To Spalten + 2
    If Cells(1, i) = "" Then Cells(1, i) = Cells(1, i - 1) & " Name"
Next

'Jahr aus KW-Spalte löschen
Range(Cells(2, KW_Col), Cells(Zeilen, 5)).Replace what:=".2009", replacement:=""

'Textzahlen umwandeln
Dim lngZ As Long, lngS As Long, lngC
lngZ = 2             ' untersuchte Zeile
For lngS = 1 To 20   ' Schleife über Spalten
    If IsNumeric(Cells(lngZ, lngS)) And Application.IsText(Cells(lngZ, lngS)) Then
        With Range(Cells(2, lngS), Cells(Zeilen, lngS))
            .Value = .Value
        End With
    End If
Next lngS

'Spalten/Zeilen ausrichten
Range(.UsedRange.Address).WrapText = False
Range(.UsedRange.Address).Offset(1, 0).Columns.AutoFit
Range(.UsedRange.Address).Offset(1, 0).Rows.AutoFit

End With 'Workbooks("Materialabweichung komplett.xls").Sheets(1)

With Workbooks("Verluste.xls").Sheets(1)
    .PivotTableWizard SourceType:=xlDatabase, SourceData:= _
        "'\Workgroup\Fehlerbeseitigung\Produktion\[Materialabweichung komplett.xls] _
SAPBW_DOWNLOAD'!R1C1:R" & "3600" & "C22"
End With

With Workbooks("Verluste.xls").Sheets(2)
    
    .PivotTables("PivotTable2").Source SourceType:=xlDatabase, SourceData:="'\Workgroup\ _
Fehlerbeseitigung\Produktion\[Materialabweichung komplett.xls]SAPBW_DOWNLOAD'!R1C1:R" & "3600" & _
 "C22"
    
    '.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
        "'\Workgroup\Fehlerbeseitigung\Produktion\[Materialabweichung komplett.xls] _
SAPBW_DOWNLOAD'!R1C1:R" & "3600" & "C22"
End With

GetMoreSpeed False

End Sub

Sub GetMoreSpeed(bYesNo As Boolean)
    Application.ScreenUpdating = Not (bYesNo)
    Application.EnableEvents = Not (bYesNo)
    Application.Calculation = IIf(bYesNo, xlCalculationManual, xlCalculationAutomatic)
    If Not bYesNo Then Calculate
End Sub '*******************************************************

  

Betrifft: Datenquelle einer Pivottabelle per VBA anpassen von: NoNet
Geschrieben am: 02.12.2009 17:02:21

Hallo David,

Du musst dazu lediglich den PivotCache der Pivottabelle ändern :
Hier die entscheidenden Zeilen zu Deinem Beispiel :

Sub PivotBereichAendern()
    Dim lngS As Long, lngZ As Long
    
    lngZ = 63 'Zeilennummer der letzten Zeile der Quelltabelle
    
    lngS = InStr(ActiveWorkbook.PivotCaches(1).SourceData, "!") 'Position des Ausrufezeichens  _
suchen
    ActiveWorkbook.PivotCaches(1).SourceData = _
        Left(ActiveWorkbook.PivotCaches(1).SourceData, lngS) & "R1C1:R" & lngZ & "C22"
End Sub
Die Variable ZEILEN aus Deinem Code heißt hier lngZ !
Der Code geht davon aus, dass die Mappe nur 1 PivotTabelle bzw. EINE Datenquelle enthält und ändert daher fix den ERSTEN PivotCache !
Falls die Mappe mehrere Pivot-Datenquellen enthält, musst Du zunächst den PivotCache-Index der betreffenden PIVOT-Tabelle ermitteln (hier : die CacheNr. der ersten Pivot-Tabelle des aktuellen Blattes) :
Sub PivotBereichAendern2()
    Dim lngS As Long, lngZ As Long, intPivotCacheNr As Integer
    
    'CacheIndex der ersten PIVOT-Tabelle des aktuellen Blattes ermitteln :
    intPivotCacheNr = ActiveSheet.PivotTables(1).PivotCache.Index
    
    lngZ = 63 'Zeilennummer der letzten Zeile der Quelltabelle
    
    'Position des Ausrufezeichens suchen :
    lngS = InStr(ActiveWorkbook.PivotCaches(intPivotCacheNr).SourceData, "!")
    ActiveWorkbook.PivotCaches(1).SourceData = _
        Left(ActiveWorkbook.PivotCaches(intPivotCacheNr).SourceData, lngS) & "R1C1:R" & lngZ & " _
C22"
End Sub

Gruß, NoNet


  

Betrifft: AW: Datenquelle einer Pivottabelle per VBA anpassen von: David
Geschrieben am: 03.12.2009 07:18:00

Hallo Nonet,

Der Code ist recht zusammengewürfelt, deswegen stellt die Variable Zeilen wohl den gleichen Wert dar wir lngZ, zumindest habe ich das im Debugger überprüfen können.
Die Mappe enthält tatsächlich mehrere Pivottabellen, deswegen war ich ja auch so erstaunt, dass der Macrorecorder keinen Bezug zu einer bestimmten Pivottabelle aufgezeichnet hat. Die VBA-Hilfe war diesbezüglich auch nicht sehr auskunftsfreudig. Das das über den "Pivotchache" läuft, darauf wäre ich nie gekommen.
Ich werde im Laufe des Tages deinen Code testen und dann noch mal Rückmeldung geben, vielen Dank erst mal soweit.

Gruß
David