Hallo Andy,
kopiere das folgende Makro in ein Standard-Modul deiner Arbeitsmappe. Bevor du das Makro ausprobierst, musst die Namen der Tabellen, die in der betreffenden Arbeitsmappe sind, im Makro anpassen. Wenn z.B. alle Tabelle in der Arbeitsmappe durchlaufen werden sollen, kann man das entsprechend einfacher machen.
Für die Liste wird automatisch ein neues Tabellenblatt angelegt.
Sub liste()
Dim strListe As String
Dim arrDaten As Variant
Dim arrTabellen As String
Dim t As Long
Dim i As Long
Dim lngLetzte As Long
Dim lngZeile As Long
Dim bExists As Boolean
Dim Antwort
'Tabellenblätter definieren, aus denen die Gesamtliste erstellt werden soll
'Namen anpassen
arrListe = Array("Tabelle2", "Tabelle3")
'Name für Übersichtsliste erstellen
If Month(Now) < 10 Then
strName = "Liste " & Year(Now) & "-0" & Month(Now) & "-" & Day(Now)
Else
strName = "Liste " & Year(Now) & "-" & Month(Now) & "-" & Day(Now)
End If
'Prüfen, ob Tabellenblatt für Übersichtsliste bereits besteht
For i = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(i).Name = strName Then
'Marker, dass Tabellenblatt existiert
bExists = True
'Schleife verlassen
Exit For
End If
Next i
'Falls Tabellenblatt noch nicht existiert, dann Tabellenblatt erstellen
If bExists = True Then
'Fragen was passieren soll
Antwort = MsgBox("Achtung! Die Tabelle " & strName & " existiert bereits! Soll die Liste neu erstellt werden?", 36, "Liste existiert schon")
If Antwort = vbNo Then
'Makro beenden, falls liste nicht neu erstellt werden soll
Exit Sub
Else
Application.DisplayAlerts = False 'keine Nachfrage anzeigen
Worksheets(strName).Delete 'vorhandenes Arbeitsblatt löschen
Application.DisplayAlerts = True 'Nachfrage wieder aktivieren
End If
End If
Worksheets.Add Before:=Worksheets(1) 'Arbeitsblatt vor dem ersten Blatt einfügen
With ActiveSheet
.Name = strName 'Arbeitsblatt benennen
'Überschriften erstellen
.Range("B1") = "Klasse"
.Range("C1") = "Name"
.Range("D1") = "Vorname"
'Überschriften formatieren
With .Range("B1:D1")
.Font.Bold = True 'Fett
.HorizontalAlignment = xlCenter 'zentriert
End With
End With
'erste Einfügezeile für die Liste festlegen
lngZeile = 2
'Tabellenblätter mit den zu kopierenden Daten durchlaufen
For t = 0 To UBound(arrListe) 'Zählung fängt hier bei Null an
With ThisWorkbook.Worksheets(arrListe(t))
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'Array Redimensionieren
ReDim arrDaten(lngLetzte - 1, 7) 'ohne 1. Zeile und Spalten A - G
'Daten aus Tabellenblatt einlesen
arrDaten = .Range("A2:G" & lngLetzte)
End With
'Daten in Gesamtliste eintragen
With ThisWorkbook.Worksheets(strName)
'Array mit Daten aus Arbeitsblatt durchlaufen
For i = 1 To UBound(arrDaten, 1)
.Cells(lngZeile, 2) = arrDaten(i, 7) 'Spalte B = Klasse
.Cells(lngZeile, 3) = arrDaten(i, 2) 'Spalte C = Name
.Cells(lngZeile, 4) = arrDaten(i, 3) 'Spalte D = Vorname
lngZeile = lngZeile + 1 'Zähler für Einfügezeile erhöhen
Next i
End With
Next t
'Nun die Daten sortieren
With ThisWorkbook.Worksheets(strName)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("B2:B" & lngZeile - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("C2:C" & lngZeile - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("D2:D" & lngZeile - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("B1:D" & lngZeile - 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Gruß
M.O.