Hallo,
da hätte ich mir vieles Ersparen können. Nun gut.
Damit man künftig die Übersicht von den Teilnehmern unterscheiden kann, bekommen die Tabellen eine neue Eigenschaft namens "Type":
Type = "Teilnehmer"
Alle Tabellen mit dieser CustomProperty werden als Teilnehmer-Tabelle behandelt.
Type = "Übersicht"
In der Arbeitsmappe darf nur eine Tabelle mit diesem Typ vorhanden sein. Falls dennoch mehrere vorhanden sein sollten, wird nur die erste Tabelle als Übersicht behandelt.
Die Umsetzung erfolgt in VBA wie folgt:
Code in DieseArbeitsmappe
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
' Existiert der gesuchte Eintrag in einer anderen Zelle?
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")
'Set wsh = ThisWorkbook.Worksheets("TabU")
If Not wsh Is Nothing Then
Set rng = wsh.Range("A10:A1048576")
If rng.Find(what:=Value) Is Nothing Then
' Freie Zelle finden
For Each rngCheck In rng.Cells
If IsEmpty(rngCheck) Then
Exit For
End If
Next
' Neuen Eintrag anlegen
If Not rngCheck Is Nothing Then
rngCheck.Value = Value
End If
End If
End If
End Sub
Code in einem Modul
Sub SetTypes()
Dim wsh As Worksheet
Set wsh = ThisWorkbook.Worksheets("TabU")
ThisWorkbook.CustomProperty(wsh, "Type") = "Übersicht"
Set wsh = ThisWorkbook.Worksheets("TabA")
ThisWorkbook.CustomProperty(wsh, "Type") = "Teilnehmer"
Set wsh = ThisWorkbook.Worksheets("TabB")
ThisWorkbook.CustomProperty(wsh, "Type") = "Teilnehmer"
End Sub
Erläuterung:
Angenommen, in der Arbeitsmappe existieren drei Tabellen:
TabA
TabB
TabU
Beim Ausführen des Befehls "SetTypes" werden die Tabellen "TabA" und "TabB" als "Teilnahmer" eingestuft.
Die Tabelle "TabU" bekommt als einzigste Tabelle den Typ "Übersicht".
Falls neue Teilnehmer-Tabellen hinzugefügt werden sollen, müssen diese erst durch die Zuweisung des Typs "Teilnehmer" als solches gekennzeichnet werden.
ThisWorkbook.CustomProperty(ThisWorkbook.Worksheets("Tabellenname"), "Type") = "Teilnehmer"
Falls bei einer Tabelle versehentlich ein Typ zugewisen wurde, kann der Typ wieder entfernt werden:
ThisWorkbook.CustomProperty(ThisWorkbook.Worksheets("Tabellenname"), "Type") = ""
Eine Muster-Arbeitsmappe kann hier heruntergeladen werden.
LG, BigBen
|