Hallo tscharl,

danke erstmals für die Nachricht. Ich habe kleine Anpassungen gemacht (Ueberischriften erweitert und die Sortierung geändert (da es auch dort geknallt hat) bin mir auch nicht sicher ob ich dadurch den Fehler erzeugt habe, den ich aktuell bekomme. Ich erhalte eine Exception "Laufzeitfehler '1004' Anwendungs- oder objektdefinierter Fehler" in der Zeile 44. Der Code sieht aktuell so aus:
 

Sub Tuncer_Teil_1()
    Dim wksQuelle As Worksheet
    Dim wks As Worksheet
    Dim i As Integer
    Dim Ueberschriften(5) As String 'Array vergrößert
    Dim lngLetzteZeile As Long
    Dim lngZaehler As Long
     
    ' Überschriften ins Array (hier mehr Überschriften hinzugefügt)
        Ueberschriften(0) = "DATUM"
        Ueberschriften(1) = "STRING 1"
        Ueberschriften(2) = "STRING 2"
        Ueberschriften(3) = "STRING 3"
        Ueberschriften(4) = "STRING 4"
     
    ' Quellblatt kopieren
    Set wksQuelle = ThisWorkbook.Worksheets("Tabelle1")
    wksQuelle.Copy After:=Sheets(Sheets.Count)
     
    ' Zielblatt benennen und auswählen (ggf. unnötig)
    Sheets(Sheets.Count).Name = "Kopie" & Sheets.Count
    Set wks = Sheets("Kopie" & Sheets.Count)
    With wks
        .Select
        ' Zeilen Auswählen und nach Datum sortieren
        lngLetzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
        With .Sort
            .SortFields.Clear
            ' zunächst nach Spalte A, danach nach Splate B sortieren (hier Add statt Add2 ???)
            .SortFields.Add Key:=Range("A1"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range("B1" & lngLetzteZeile), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A2:D" & lngLetzteZeile)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
         
        ' Zwischen den Zeilen jeder Datumsklasse eine Leere Zeile einfügen
        For lngZaehler = lngLetzteZeile To 3 Step -1
            If .Cells(lngZaehler, 1).Value <> .Cells(lngZaehler - 1, 1) Then
                Rows(lngZaehler).Select
                 
                ' 1 Zeile einfügen, dabei Überschrift einsetzen
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                For i = 0 To 5
                    .Cells(lngZaehler, i + 1).Value = Ueberschriften(i)
                Next i
                 
                ' 1 Trennzeile einfügen
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next lngZaehler
    End With
    Set wks = Nothing
    Set wksQuelle = Nothing
End Sub