dachte ich mir- mit dem code danach kommt der überlauf nicht. trägt er was ein? hier der code nochmal.

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
                 
                If zeile > Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row + 2 Then gefunden = True
                 
            Wend
        End If
    End If
End If
 
End Sub