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
If
Target.Row > 8
Then
suche = Worksheets(Sh.Index).Cells(Target.Row, 1)
Set
ergebnis = Worksheets(4).Columns(1).Find(suche, LookIn:=xlValues)
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
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
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