Hallo Satt,
der folgende Code kopiert die Daten entsprechend den Werten der Spalte H in einzelne Arbeitsblätter. Sofern deine Tabelle1 anders heißt, musst du den Namen im Code entsprechend anpassen. Das Makro gehört in ein Modul deiner Arbeitsmappe. Es wird nicht geprüft, ob die einzelnen Tabellen in der Arbeitsmappe bereits existieren. Schau mal, ob das so für dich funktioniert:
Sub sort_copy()
Dim lngLetzte As Long
Dim lngZaehler As Long
Dim arrDaten As Variant
Dim arrH As Variant
Dim i As Long
Dim j As Long
Dim s As Long
Dim bExist As Boolean
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
'letzte beschriebene Zeile in Spalte H ermitteln
lngLetzte = .Cells(Rows.Count, 8).End(xlUp).Row
'Daten aus Blatt in Array einlesen
arrDaten = .Range("A1:M" & lngLetzte)
End With
'Array für Zahlen redimensionieren
ReDim arrH(lngLetzte)
'nun die einzelnen Einträge in Spalte H ermitteln
'dafür den ersten Eintrag aus Zeile 2 vornehmen (in Zeile 1 befinden sich die Überschriften)
arrH(lngZaehler) = arrDaten(2, 8)
'nun das Feld ab Zeile 3 durchlaufen und die Zahlen mit den vorhandenen Einträgen der Einzelzahlen vergleichen
For i = 3 To UBound(arrDaten, 1)
'Marker für gefundenen Eintrag zurück setzen
bExist = False
'Feld H durchlaufen und Einträge vergleichen
For j = 1 To lngZaehler
If arrDaten(i, 8) = arrH(j) Then
'Marker auf wahr setzen, wenn Eintrag bereits vorhanden
bExist = True
'Schleife verlassen
Exit For
End If
Next j
'falls keine Übereinstimmung gefunden, dann Zahl in Array aufnehmen
If bExist = False Then
lngZaehler = lngZaehler + 1
arrH(lngZaehler) = arrDaten(i, 8)
End If
Next i
'nun Array H redimensionieren
ReDim Preserve arrH(lngZaehler)
'nun die Daten nach den einzelnen Einträgen aus Spalte H trennen
'arrH wird durchlaufen
For i = LBound(arrH) To UBound(arrH)
'neues Arbeitsblatt am Ende einfügen
ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
With ActiveSheet
'und benennen
.Name = arrH(i)
'Überschriften in das neue Tabellenblatt schreiebn
For s = 1 To 13
.Cells(1, s) = arrDaten(1, s)
Next s
'Zähler für Zeilen auf 1 festlegen
lngZaehler = 1
'nun alle Daten durchlaufen und übereinstimmende Datensätze in neues Blatt schreiben
For j = 2 To UBound(arrDaten, 1)
If arrH(i) = arrDaten(j, 8) Then
'Zähler für Einfügezeile um 1 erhöhen
lngZaehler = lngZaehler + 1
'Datensätze in Blatt schreiben
For s = 1 To 13
.Cells(lngZaehler, s) = arrDaten(j, s)
Next s
End If
Next j
'Spaltenbreite automatisch anpassen
.Columns("A:M").EntireColumn.AutoFit
End With
Next i
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Gruß
M.O.
