AW: nachgefragt ...
28.10.2015 12:03:19
matthias
Okay,
das ging doch einfacher wie gedacht, wie du siehst sind nicht viele Änderungen notwendig gewesen:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rZelle As Range, rDaten As Range
Dim fRow() As Long, fDaten()
Dim i As Long, j As Long, lSpalte As Long
Dim sFormula As String
'Eingabebereich = "Abwesend"
If Not Intersect(Target, Range("P:AG")) Is Nothing Then
With Sheets("Daten") 'Liste der Namen
Set rDaten = .Range("D2:D" & .Cells(.Rows.Count, 4).End(xlUp).Row)
End With
'Bestimmung betroffener Zeilen
ReDim fRow(0)
For Each rZelle In Intersect(Target, Range("P:AG")).Cells
For i = LBound(fRow) To UBound(fRow)
If rZelle.Row = fRow(i) Then GoTo NextrZelle1
Next i
'Zeilen merken
If rZelle.Row > 3 Then
ReDim Preserve fRow(UBound(fRow) + 1)
fRow(UBound(fRow)) = rZelle.Row
End If
If UBound(fRow) For lSpalte = 1 To 4 'Kunden 1=A / 2=B / 3=C / 4=Abwesend
'Für jede Zeile Datenüberprüfung setzen
For i = fRow(LBound(fRow) + 1) To fRow(UBound(fRow))
ReDim fDaten(0)
For Each rZelle In rDaten.Cells
If lSpalte "x" Then GoTo NextrZelle2 'kein "x"
End If
For j = 16 To 33 'P:AG
If Left(Cells(i, j), 5) = "Team " Then 'Team erkannt
If Right(Cells(i, j), Len(Cells(i, j)) - 5) = rZelle.Offset(0, 4) _
Then GoTo NextrZelle2
Else
If rZelle = Cells(i, j) Then GoTo NextrZelle2
End If
Next j
ReDim Preserve fDaten(UBound(fDaten) + 1)
fDaten(UBound(fDaten)) = rZelle
NextrZelle2:
Next rZelle
If UBound(fDaten)
'Inhalt der Liste bestimmen
For j = LBound(fDaten) + 1 To UBound(fDaten)
If j = 1 Then
sFormula = CStr(fDaten(j))
Else
sFormula = sFormula & "," & CStr(fDaten(j))
End If
Next j
ListeSetzen:
'Liste der DÜ setzen
If lSpalte = 4 Then
Set rZelle = Range(Cells(i, 16), Cells(i, 33)) 'Validation-Range
Else
Set rZelle = Union(Cells(i, lSpalte + 3), _
Cells(i, lSpalte + 7), _
Cells(i, lSpalte + 11))
End If
With rZelle.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=sFormula
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Next i
Next lSpalte
End If
End Sub
Im Grunde wird nun für jeden Kunden (A bis C) das Datenfeld neu gefüllt und die Datenüberprüfung in der entsprechenden Spalte gesetzt. Das ganze noch ein viertes Mal für den "Bereich Abwesend".
Ist die Datenzelle ein Kunde (lSpalte
Der zweite wichtige Unterschied ist, dass beim setzen der Überprüfung die Range gewählt wird, je nach Kunde/Bereich "Abwesend" und damit nur für diese Spalten gültig wird.
Eine kleine Sache wäre da noch, falls das Datenfeld nun leer sein sollte, weil zuviele abwesend sind (Bsp. beide Teams abwesend und damit für Kunde B keiner zuständig), wird als Formel " - " ausgegeben. Ohne dies würde bei einem leeren Datenfeld die Formel nicht neu berechnet und die sFormula vom vorangegangenen Kunden genommen, was ja nicht erwünscht ist.
Natürlich stimmt deine Dropdown nur wenn du einmal etwas in dem Feld auswählst, denn sonst gilt noch die alte Datenüberprüfung. Dazu einfach in der obersten Zeile einen Namen auf abwesend stellen und diesen nach unten ziehen. Dabei kommt dir zugute dass du eine bedingte Formatierung genutzt hast, wodurch die Farben nicht mitgezogen werden. Anschließend den Namen wieder überall rauslöschen. Er rattert zwar kurz, aber das kommt daher dass es A viele Zeilen sind und B das Makro echt viele Schleifen für deine kleine Spielerei besitzt.
lg Matthias