Hallo! Hatte Nachtschicht, ging nicht früher. Also hier jetzt der neue Code. Wenn du Zeilen einfügst oder am ENde der Tabellen 1 bis 3 ein Datum nochmal einträgst, wird es hinten mit aufgelistet. Habe auch die Beschriftung geändert. Einzig Löschen von Zeilen erkennt er nicht - dann gibt es ja kein Datum mehr und er kann nichts finden. Wieder an der selben Stelle einfügen und ggf. die Tabelle 4 nochmal löschen. Gruß

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim suche
Dim ergebnis As Object
Dim ergebnissh As Object
Dim ende As Long
Dim endesh As Long
Dim anzahl As Long
Dim i As Long
Dim zeile As Integer
Dim zeilesh As Integer
Dim gefunden As Boolean
Dim adresse As String

If Sh.Index < 4 Then 'nur wenn Blatt 1bis 3
    If Target.Row > 8 Then  'Eintrag ab 9
    suche = Worksheets(Sh.Index).Cells(Target.Row, 1) 'datum wird gesucht
        
    Set ergebnis = Worksheets(4).Columns(1).Find(suche, LookIn:=xlValues)  'suche von datum in Blatt 4
        If ergebnis Is Nothing Then
        ende = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets(4).Cells(ende + 1, 1) = suche
        Worksheets(Sh.Index).Rows(Target.Row).Copy Destination:=Worksheets(4).Rows(ende + 1 + Sh.Index)
        Worksheets(4).Cells(ende + 2, 1) = "Raum1"
        Worksheets(4).Cells(ende + 3, 1) = "Raum2"
        Worksheets(4).Cells(ende + 4, 1) = "Raum3"
        
        Else
        'es gibt eine wert suchen und eintragen
            zeile = ergebnis.Row + 1
            gefunden = False
                        
            While gefunden = False
                If Left(Worksheets(4).Cells(zeile, 1), 4) = "Raum" And Right(Worksheets(4).Cells(zeile, 1), 1) = Trim(Sh.Index) Then
                    gefunden = True
                    anzahl = Application.WorksheetFunction.CountIf(Worksheets(Sh.Index).Range(Worksheets(Sh.Index).Cells(9, 1), Cells(Rows.Count, 1)), suche)
                   
                        Set ergebnissh = Worksheets(Sh.Index).Columns(1).Find(suche, LookIn:=xlValues)
                        zeilesh = ergebnissh.Row
                        
                        For i = 1 To anzahl
                        
                        If Left(Worksheets(4).Cells(zeile, 1), 4) = "Raum" And Right(Worksheets(4).Cells(zeile, 1), 1) = Trim(Sh.Index) Then
                            Worksheets(Sh.Index).Rows(zeilesh).Copy Destination:=Worksheets(4).Rows(zeile)
                            Worksheets(4).Cells(zeile, 1) = "Raum" & Trim(Sh.Index)
                        Else
                        'neuer wert, zeile einfügen
                            Worksheets(4).Rows(zeile).EntireRow.Insert Shift:=xlDown
                            Worksheets(Sh.Index).Rows(zeilesh).Copy Destination:=Worksheets(4).Rows(zeile)
                            Worksheets(4).Cells(zeile, 1) = "Raum" & Trim(Sh.Index)
                        End If
                        If i < anzahl Then
                        Set ergebnissh = Worksheets(Sh.Index).Columns(1).FindNext(ergebnissh)
                        zeilesh = ergebnissh.Row
                        End If
                        
                        zeile = zeile + 1
                    Next i
                Else
                    zeile = zeile + 1
                End If
            Wend
        End If
    End If
End If

End Sub