Gut ich glaube wir nähern uns. Folgenden Code mal bitte einfügen und hinter einem Datum was eintragen. Dann sollte eine Messagbox aufpoppen. Da bräcuhte ich mal den INhalt. Der beginnt mit A
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
MsgBox "A" & Left(Worksheets(4).Cells(zeile, 1), 4) & "A" & Right(Worksheets(4).Cells(zeile, 1), 1) & "A"
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
|