Option
Explicit
Private
Sub
Workbook_SheetChange(
ByVal
Sh
As
Object
,
ByVal
Target
As
Range)
Dim
sTyp
As
String
Dim
rngNew
As
Range
Dim
wsh
As
Worksheet
If
VBA.TypeName(Sh) =
"Worksheet"
Then
Set
wsh = Sh
sTyp = CustomProperty(wsh,
"Type"
)
Select
Case
sTyp
Case
"Teilnehmer"
For
Each
rngNew
In
Target.Cells
If
rngNew.Row >= 4
Then
If
WorksheetFunction.CountIf(Target.Worksheet.Range(
"A4:A1048576"
), rngNew.Value) = 1
Then
FillOverviewWorksheet rngNew.Value
End
If
End
If
Next
Case
Else
End
Select
End
If
End
Sub
Property
Let
CustomProperty(wsh
As
Worksheet, sName
As
String
, sValue
As
String
)
Dim
iProp
As
Integer
Dim
bFound
As
Boolean
With
wsh
For
iProp = 1
To
wsh.CustomProperties.Count
With
.CustomProperties.Item(iProp)
If
.Name = sName
Then
If
sValue =
""
Then
.Delete
Else
.Value = sValue
End
If
bFound =
True
Exit
For
End
If
End
With
Next
If
Not
bFound
And
Not
sValue =
""
Then
.CustomProperties.Add Name:=sName, Value:=sValue
End
If
End
With
End
Property
Property
Get
CustomProperty(wsh
As
Worksheet, sName
As
String
)
As
String
Dim
iProp
As
Integer
Dim
bFound
As
Boolean
With
wsh
For
iProp = 1
To
wsh.CustomProperties.Count
With
.CustomProperties.Item(iProp)
If
.Name = sName
Then
CustomProperty = .Value
Exit
For
End
If
End
With
Next
End
With
End
Property
Function
SearchWorksheetsCustomProperty(sName
As
String
, sValue
As
String
)
As
Worksheet
Dim
wsh
As
Worksheet
For
Each
wsh
In
ThisWorkbook.Worksheets
If
CustomProperty(wsh, sName) = sValue
Then
Set
SearchWorksheetsCustomProperty = wsh
Exit
For
End
If
Next
End
Function
Private
Sub
FillOverviewWorksheet(Value
As
String
)
Dim
rng
As
Range
Dim
rngCheck
As
Range
Dim
wsh
As
Worksheet
Set
wsh = SearchWorksheetsCustomProperty(
"Type"
,
"Übersicht"
)
If
Not
wsh
Is
Nothing
Then
Set
rng = wsh.Range(
"A10:A1048576"
)
If
rng.Find(what:=Value)
Is
Nothing
Then
For
Each
rngCheck
In
rng.Cells
If
IsEmpty(rngCheck)
Then
Exit
For
End
If
Next
If
Not
rngCheck
Is
Nothing
Then
rngCheck.Value = Value
End
If
End
If
End
If
End
Sub