Home > Computer > Coding > Visual Basic (VBA) / Excel / Access > Pivottabelle auslesen
Pivottabelle auslesen:
Aufgabenbeschreibung
Die folgende vorgestellte Excel-VBA-Anwendung dient dem Auslesen von Daten in einer Pivottabelle, um sie an anderer Stelle individuell einzufügen. Der Aufbau der Pivottabelle kann sich dabei in bestimmten Bahnen verändern, ohne das die Funktion davon beeinflusst wird.
Im eigentliche Anwendungsfall benutze ich diese Funktion als einen Baustein für einen umfangreicheren Anwendungsfall, die Funktion als solches ist aber sicherlich individuell einsetzbar.Für die Beschreibung habe ich daher folgendes Beispiel gewählt:
Wir erhalten aus verschiedenen Fabriken, nehmen wir mal an 99 Stück, die Produktionslisten eines Geschäftsjahres und sollen diese Werte gruppieren und nach bestimmten Kriterien in einen Bericht einfügen. Die Auswertungsform ist dabei im Grunde für alle Fabriken respektive Produktionsgebiete gleich, es ändern sich aber jeweils der Produktionsumfang und die gewünschten Schwerpunkte der Berichte. Zudem kommt es immer wieder vor, dass nach der Übergabe der Produktionslisten die jeweiligen Zuständigen doch noch eine schnelle Aktualisierung übergeben, da die erste Liste noch Fehler enthielt. Wie das Leben halt so ist...
Zielsetzung ist es, nur die Daten je Produktionsgebiet zu ändern und jeweils automatisch den Bericht generieren zu lassen. Wenn man dies sonst 99x von Hand machen würde, wären schnell einige Stunden vorbei und zudem hat es ein hohes Fehlerpotenzial. Wir möchten aber nur max. 3 Stunden damit verbringen.
Zudem ist es uns wichtig, dass die individuelle Anpassung der Berichte je Gebiet sehr einfach möglich sein sollte, ansonsten stoßen wir später schnell an die Grenzen der Automatisierung. Die in letzter Sekunde übersandte Aktualisierungen der Listen sollten uns nicht nervös machen und im Folgejahr wollen wir von dem einmaligen Arbeitsaufwand der weitgehenden Automatisierung deutlich profitieren.
Sicherlich gibt es durchaus bessere Fallbeschreibungen, mir ist aber leider nicht anderes eingefallen.
Umsetzung
Die Datei auswertung_starten.xlsm enthält den Bericht der ausgefüllt werden soll. Die Datei datenquelle.xlsx ist die Produktionsliste eines Produktionsgebietes. Sie wird später je nach Gebiet ausgetauscht.
Wenn die Datei auswertung_starten.xlsm gestartet wird muss hier zunächst die Makrofunktion eingeschaltet werden.
Bei jedem Klick auf „Formular ausfüllen“ werden dann die Daten der Datei datenquelle.xlsx neu eingelesen.
Die Daten der werden zunächst in einer Pivottabelle gruppiert. Damit die Daten in den Bericht eingefügt werden können, werden alle benötigten Werte via Makro in ein Array eingelesen.
Um die Werte anschließend in den Bericht einzufügen, muss lediglich die Zelle der Tabelle "Userdefiniert" den entsprechenden Namen erhalten.
Zur Kontrolle werden alle eingelesenen Werte in einem Protokoll ausgegeben.
Die beschriebenen Dateien können hier als Archivdateien (ZIP mit Excel 2007 / xlsm - Files) herunterladen werden.
Wer kein Excel 2007 nutzt, benötigt in älteren Excelversionen (z.B. Excel 2003) den Konverter von Microsoft (Microsoft Office Compatibility Pack...).
Quelltext
Option Explicit
Dim path As String
Dim WB_datenquelle As Workbook
Dim WB As Workbook
Dim WS_Übernahme As Worksheet
Dim WS_Userdefiniert As Worksheet
Dim WS_Übernahmeprotokoll As Worksheet
Sub Datei_Oeffnen()
Dim dauer As Single
dauer = Timer 'Die Zeit für die Ausführung wird ermittelt
Set WB = ThisWorkbook
Set WS_Übernahmeprotokoll = WB.Worksheets("Übernahmeprotokoll")
Set WS_Userdefiniert = WB.Worksheets("Userdefiniert")
'Falls die Datei geöffnet ist, wird sie jetzt geschlossen
Application.DisplayAlerts = False
On Error Resume Next
Workbooks("datenquelle.xlsx").Save
Workbooks("datenquelle.xlsx").Close
On Error GoTo 0
Application.DisplayAlerts = True
path = ThisWorkbook.path
'Falls es die Datei nicht gibt, wird das Programm beendet
If Dir(path & "\datenquelle.xlsx") = "" Then
MsgBox Prompt:="Die Datei " & path & "\datenquelle.xlsx wurde nicht in gefunden." & _
" Sie muss sich im gleichen Ordner wie diese Datei befinden.", _
Buttons:=vbCritical
Exit Sub
End If
'Die ProjektÜbersicht wird geöffnet
Set WB_datenquelle = Workbooks.Open(path & "\datenquelle.xlsx")
Set WS_Übernahme = WB_datenquelle.Worksheets("Übernahme")
Set WS_Übernahmeprotokoll = WB.Worksheets("Übernahmeprotokoll")
Werte_auslesen
Application.DisplayAlerts = False
Application.ScreenUpdating = False
WB_datenquelle.Save
WB_datenquelle.Close
Application.DisplayAlerts = True
WB.Save
Application.ScreenUpdating = True
dauer = Timer - dauer
Application.StatusBar = "Dauer: " & Format$(dauer, "0.0 \S\e\k\.")
End Sub
Sub Werte_auslesen()
Dim ANfZeile As Long
Dim GRoesseenanzahl As Long
Dim GRoesse(1 To 6) As String
Dim GRoesseenauflistung As String
Dim ENdZeile As Long
Dim GEfunden As String
Dim GEsamtsumme As Variant
Dim i As Long
Dim ii As Long
Dim LAnfZeile As Long
Dim LEtzteZeile As Long
Dim WArengruppe(1 To 8) As String 'muss bei mehr als 10 WArengruppen erweitert werden
Dim WArengruppenanzahl As Long
Dim WArengruppenauflistung As String
Dim ZEile As Long
Dim ZEile1 As Long
Dim ZEiLe2 As Long
Dim zf As Long
Application.ScreenUpdating = False
'####################################
'Hier werden die Kriterien festgelegt
'####################################
WArengruppe(1) = "TShirts"
WArengruppe(2) = "Hemden"
WArengruppe(3) = "Pullover"
WArengruppe(4) = "Sweatshirts"
WArengruppe(5) = "Jeans"
WArengruppe(6) = "Hosen"
WArengruppe(7) = "Anzüge"
WArengruppe(8) = "Unterwäsche"
GRoesse(1) = "XXL"
GRoesse(2) = "XL"
GRoesse(3) = "L"
GRoesse(4) = "M"
GRoesse(5) = "S"
GRoesse(6) = "XS"
WArengruppenanzahl = 8 'Hier bitte die Gesamtanzahl an WArengruppen angeben
GRoesseenanzahl = 6 'Hier bitte die Gesamtanzahl an GRoesseen angeben
'####################################
'Ende der Kriterienvergabe
'####################################
WS_Übernahme.PivotTables("PivotTable1").PivotCache.Refresh
LEtzteZeile = WS_Übernahme.Cells(WS_Übernahme.Rows.Count, "A").End(xlUp).Row
ZEiLe2 = 2
For i = 1 To WArengruppenanzahl
WArengruppenauflistung = WArengruppenauflistung & "WArengruppe " _
& WArengruppe(i) & ", "
Next i
For i = 1 To GRoesseenanzahl
GRoesseenauflistung = GRoesseenauflistung & "Besonderes Merkmal (bitte auf Schreibweise achten) " _
& GRoesse(i) & vbNewLine
Next i
zf = MsgBox(Prompt:="Es wird nach " & WArengruppenanzahl & " WArengruppen gesucht:" & _
vbNewLine & vbNewLine & WArengruppenauflistung & vbNewLine & _
vbNewLine & "Innerhalb der WArengruppen jeweils nach folgenden besonderen Merkmalen:" & _
vbNewLine & vbNewLine & GRoesseenauflistung & _
vbNewLine & "Die enstprechenden Gesamtsummen werden übernommen." & _
vbNewLine & "Vorgang starten?", _
Buttons:=vbYesNo, _
Title:="Parameterinfo")
If zf = 7 Then
Exit Sub
End If
WS_Übernahmeprotokoll.UsedRange.ClearContents
WS_Übernahmeprotokoll.Cells(1, 1) = "Warengruppe"
WS_Übernahmeprotokoll.Cells(1, 2) = "GRoesse"
WS_Übernahmeprotokoll.Cells(1, 3) = "Gesamtpreis"
'Der Anfang der WArengruppen wird gesucht
For i = 1 To WArengruppenanzahl
GEfunden = "Nein"
For ZEile1 = 1 To LEtzteZeile
If WS_Übernahme.Cells(ZEile1, "A") = WArengruppe(i) Then
'Die letzte Zeile zur WArengruppe wird gesucht
ANfZeile = ZEile1
ZEile = ZEile1 + 1
GEfunden = "Ja"
Do Until Not IsEmpty(WS_Übernahme.Cells(ZEile, "A"))
ZEile = ZEile + 1
Loop
ENdZeile = ZEile
End If
Next ZEile1
'Die gefundenen Zeilen werden nach der BeschäftigungsGRoesse durchsucht
'und die enstprechende Zeile kopiert
For ii = 1 To GRoesseenanzahl
For ZEile = ANfZeile To ENdZeile - 1
If GEfunden = "Ja" Then
If WS_Übernahme.Cells(ZEile, "B") = GRoesse(ii) Then
WS_Übernahme.Range(WS_Übernahme.Cells(ZEile, "A"), WS_Übernahme.Cells(ZEile, "C")). _
Copy Destination:=WS_Übernahmeprotokoll.Cells(ZEiLe2, "A")
WS_Übernahmeprotokoll.Cells(ZEiLe2, "A") = WArengruppe(i)
GEsamtsumme = GEsamtsumme + WS_Übernahmeprotokoll.Cells(ZEiLe2, "C")
On Error Resume Next
WS_Userdefiniert.Range(GRoesse(ii) & WArengruppe(i) & "b") = WS_Übernahmeprotokoll.Cells(ZEiLe2, "A") & " / " & WS_Übernahmeprotokoll.Cells(ZEiLe2, "B")
WS_Userdefiniert.Range(GRoesse(ii) & WArengruppe(i)) = WS_Übernahmeprotokoll.Cells(ZEiLe2, "C")
WS_Userdefiniert.Range(GRoesse(ii) & WArengruppe(i)).Font.Underline = True
On Error GoTo 0
With WS_Übernahmeprotokoll.Cells(ZEiLe2, 3)
.HorizontalAlignment = xlHAlignRight
.Style = "Currency"
End With
ZEiLe2 = ZEiLe2 + 1
Else
End If
End If
Next ZEile
Next ii
Next i
Application.ScreenUpdating = True
MsgBox Prompt:="Es wurden Beträge in der Gesamtsumme von" & vbNewLine & _
Format$(GEsamtsumme, "#,##0.00 Ä") & " übernommen.", _
Buttons:=vbInformation, _
Title:="Statusmeldung"
End Sub