Hallo ! Da bin ich wieder. Keine Angst - mein Ergeiz war da geweckt. Hat mich zwar ein wenig Zeit (länger als erwartet) und Nerven gekostet (es lief mal und wollte dann plötzlich dann doch nicht mehr) aber jetzt läuft es. Da ich mit einer alten Excelversion werkel, musste ich die xlsm erst noch umwandeln. Danach konnte ich sie zwar nicht mehr nutzen, aber zumindest die Tabellenblätter übernehmen. Mit deinem Sheetaufbau habe ich es nun hingebastelt. Einfach wieder einfügen und dann sollte es klappen. Falls wiedererwarten doch nicht, einfach nochmal melden. Gruß

Anbei noch der Link zu meiner Datei (da sind die ausgeblendeten Sheets und Diese Arbeitsmappe2 nicht mit dabei.

http://www.file-upload.net/download-11134339/zeilenkopierenrumeneu.xls.html

und hier der code zum enfügen.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim suche
Dim ende As Long
Dim ende2 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
Dim blatt()
Dim temp
Dim anzsuch

blatt = Array("", "Kursaal", "Galerie", "Konferenzraum")

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
    anzsuch = 0
    anzsuch = Application.WorksheetFunction.CountIf(Worksheets(4).Columns(1), suche)
    If suche = "" Then Exit Sub

        If anzsuch = 0 Then
        ende = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets(4).Cells(ende + 1, 1) = suche
        Worksheets(4).Cells.Rows(ende + 1).Borders(xlInsideVertical).LineStyle = xlNone
        Worksheets(4).Cells.Rows(ende + 1).Borders(xlEdgeLeft).LineStyle = xlNone
        Worksheets(4).Cells.Rows(ende + 1).Borders(xlEdgeRight).LineStyle = xlNone
        Worksheets(Sh.Index).Rows(Target.Row).Copy Destination:=Worksheets(4).Rows(ende + 1 + Sh.Index)
        Worksheets(4).Cells(ende + 2, 1) = suche
        Worksheets(4).Cells(ende + 2, 4) = blatt(1)
        Worksheets(4).Cells(ende + 3, 1) = suche
        Worksheets(4).Cells(ende + 3, 4) = blatt(2)
        Worksheets(4).Cells(ende + 4, 1) = suche
        Worksheets(4).Cells(ende + 4, 4) = blatt(3)
       
        Else
        'es gibt eine wert suchen und eintragen
            suche = CLng(CDate(suche))
            
            zeile = Application.WorksheetFunction.Match(CLng(suche), Worksheets(4).Columns(1), 0)
            zeile = zeile + 1
            gefunden = False
            
            While gefunden = False
                If Worksheets(4).Cells(zeile, 4) = blatt(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)
                    
                       temp = Application.WorksheetFunction.Match(CLng(suche), Worksheets(Sh.Index).Columns(1), 0)
       
                        zeilesh = temp
                        
                        For i = 1 To anzahl
                        
                        If Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index)) Then
                            Worksheets(Sh.Index).Rows(zeilesh).Copy Destination:=Worksheets(4).Rows(zeile)
                            Worksheets(4).Cells(zeile, 4) = blatt(Trim(Sh.Index))
                            Worksheets(4).Cells(zeile, 1) = CDate(suche)
                        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, 4) = blatt(Trim(Sh.Index))
                            Worksheets(4).Cells(zeile, 1) = CDate(suche)
                        End If
                        If i < anzahl Then
                        ende2 = Worksheets(Sh.Index).Cells(Rows.Count, 1).End(xlUp).Row
                        temp = Application.WorksheetFunction.Match(CLng(suche), Worksheets(Sh.Index).Columns(1).Rows(zeilesh & ":" & ende2), 0)
                        zeilesh = temp + zeilesh
                        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
Worksheets(4).Cells.Interior.ColorIndex = xlNone
End Sub