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
|