Zum Inhalt springen.
Zum Seitenanfang springen.
Sie befinden sich genau hier:

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 individuell nutzbar.

Für die Beschreibung habe ich daher folgendes Beispiel gewählt:

Wir erhalten aus verschiedenen Fabriken insgesamt 99 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.

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.

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.

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.


Der Download wurde entfernt. Diese Datei kann leider nicht mehr heruntergeladen 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