Pivottabelle in VBA
David
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 '*******************************************************