AW: Gesamtübersicht erstellen
18.06.2007 03:05:00
fcs
Hallo TC,
leider funktioniert der Link auf deine Beispieldatei bei mir nicht, so dass du mein Makro selber anpassen muss..
Mit folgenden Makros kannst du deine Übersicht immer neu generieren. Dabei werden jeweils alle Daten aus den anderen Tabellen neu eingelesen. Im 1. Makro muss du die Parameter für deine Tabellenblätter entsprechend den Erläuterungen zu den Variablen im 2. Makro anpassen. Das Makro funktioniert nur einwandfrei, wenn in der 1. Daten-Spalte der Tabellen alle Zeilen ausgefüllt sind. Falls das nicht der Fall ist, dann muss der Code in der Zeile, in der die letzte Datenzeile in der Quelltabelle ermittelt wird, angepasst werden.
Gruß
Franz
Sub UebersichtAktualiseren()
'Überträgt die Daten gleichartiger Tabellenblätter in ein Übersichtsblatt
Call BlattAktualisieren(Blattname:="Uebersicht", ZeileZ1:=3, ZeileQ1:=2, SpalteQ1:=1, _
SpaltenQ:=6, SortSpalte1:=6, SortSpalte2:=1, bTabName:=False, bKopieren:=True)
End Sub
Sub BlattAktualisieren(Blattname$, ZeileZ1 As Long, ZeileQ1 As Long, SpalteQ1%, SpaltenQ%, _
Optional SortSpalte1% = 0, Optional SortSpalte2% = 0, Optional SortSpalte3% = 0, _
Optional bTabName As Boolean = False, Optional bKopieren As Boolean = False)
'Daten aus den anderen Tabellenblättern werden als Liste im Blatt eingetragen
'Blattname = Name der Übersichtstabelle
'ZeileZ1 = 1. Zeile mit Daten im Übersichtsblatt mit Daten
'ZeileQ1 = 1. Zeile mit Daten in den Quell-Tabellenblättern
'SpalteQ1 = 1. Datenspalte in Quell-Tabellenblättern
'SpaltenQ = Letzte Datenspalte in Quell-Tabellenblättern
'SortSpalte1 bis SortSpalte3 = Optional Reihenfolge der Spalten bei Sortierung
'bTabname = Wenn True wird in jeder Zeile der Quellen-Tabellenname eingetrage
'bKopieren = Wenn True, dann werden die Werte per Kopieren in die Übersicht übertragen _
erforderlich, wenn z.B. Währungsformate in den Quellen verwendet werden.
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim rngQuelle As Range
Dim ZeileZ As Long, ZeilenQ As Long
Set wksZiel = ThisWorkbook.Worksheets(Blattname)
Application.ScreenUpdating = False
With wksZiel
'Alte Daten in der Liste löschen
If .Cells.SpecialCells(xlCellTypeLastCell).Row >= ZeileZ1 Then
.Range(.Cells(ZeileZ1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
'Tabellenblätter auslesen
ZeileZ = ZeileZ1
For Each wksQuelle In ThisWorkbook.Worksheets
If wksQuelle.Name wksZiel.Name Then
'Letzte Datenzeile in Quelldatentabelle
ZeilenQ = wksQuelle.Cells(wksQuelle.Rows.Count, SpalteQ1).End(xlUp).Row
'Werte aus den Zellen übertragen
Set rngQuelle = wksQuelle.Range(wksQuelle.Cells(ZeileQ1, SpalteQ1), _
wksQuelle.Cells(ZeilenQ, SpaltenQ))
If bKopieren = True Then
'Werte Übertragen per Kopierfunktion (erforderlich bei betimmten Zellformaten)
rngQuelle.Copy
.Cells(ZeileZ, 1).Range(Cells(1, 1), Cells(rngQuelle.Rows.Count, _
rngQuelle.Columns.Count)).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Else
'Werte Übertragen per direkter Wertzuweisung (geht schneller)
.Cells(ZeileZ, 1).Range(Cells(1, 1), Cells(rngQuelle.Rows.Count, _
rngQuelle.Columns.Count)).Value = rngQuelle.Value
End If
If bTabName = True Then
'Tabellennamen hinter Daten eintragen
.Range(.Cells(ZeileZ, SpaltenQ - SpalteQ1 + 1), _
.Cells(ZeileZ + rngQuelle.Rows.Count - 1, SpaltenQ - SpalteQ1 + 1)).Value _
= wksQuelle.Name
End If
ZeileZ = ZeileZ + rngQuelle.Rows.Count
End If
Next wksQuelle
'Datensortieren
If SortSpalte1 > 0 And SortSpalte2 > 0 And SortSpalte3 > 0 Then
.Range(.Cells(ZeileZ1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Sort _
Key1:=.Cells(ZeileZ1, SortSpalte1), Order1:=xlAscending, _
Key2:=.Cells(ZeileZ1, SortSpalte2), Order2:=xlAscending, _
Key3:=.Cells(ZeileZ1, SortSpalte3), Order3:=xlAscending, Header:=xlNo
ElseIf SortSpalte1 > 0 And SortSpalte2 > 0 Then
.Range(.Cells(ZeileZ1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Sort _
Key1:=.Cells(ZeileZ1, SortSpalte1), Order1:=xlAscending, _
Key2:=.Cells(ZeileZ1, SortSpalte2), Order2:=xlAscending, Header:=xlNo
ElseIf SortSpalte1 > 0 Then
.Range(.Cells(ZeileZ1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Sort _
Key1:=.Cells(ZeileZ1, SortSpalte1), Order1:=xlAscending, Header:=xlNo
End If
End With
Application.ScreenUpdating = True
End Sub