Hi zusammen,
es hat mich mal interessiert, ob das so hinhauen könnte:
Option Explicit
Const abSp = 7, abZ = 4, bisZ = 9, Nvon = 11, Nbis = 25
Dim aNamen, aNok As Boolean, liSpLetzte&, letzter As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim bisSp&, liSp&, z&, y&
Dim aEin, aFix, sEin$, sList$
bisSp = Cells(3, Columns.Count).End(xlToLeft).Column + 5
If Not aNok Then aNamen = Range(Cells(Nvon, abSp), Cells(Nbis, abSp)): aNok = True
If Not Intersect(Target, Range(Cells(abZ, abSp), Cells(bisZ, bisSp))) Is Nothing Then
liSp = Int((Target.Column - 1) / 6) * 6 + 1
If liSp = liSpLetzte Then
If letzter Then MsgBox "keiner mehr da": Exit Sub
Else
letzter = False
End If
aEin = Range(Cells(abZ, liSp), Cells(bisZ, liSp + 5))
For z = 1 To UBound(aEin)
For y = 1 To UBound(aEin, 2)
If aEin(z, y) "" Then sEin = sEin & aEin(z, y) & ","
Next
Next
If Trim(Target.Text) "" Then y = 1: sList = Target.Text & "," Else y = 0
For z = 1 To UBound(aNamen)
If InStr(sEin, aNamen(z, 1)) = 0 Then sList = sList & aNamen(z, 1) & ",": y = y + 1
Next
If y > 0 Then sList = Left(sList, Len(sList) - 1)
Range(Cells(abZ, abSp), Cells(bisZ, bisSp)).Validation.Delete ' alle fort, die evtl. da sind
If y
Die Datei: https://www.herber.de/bbs/user/109487.xlsm
Die Grundidee ist, daß ein Gültigkeitskreis in die eben angeklickte Zelle eingefügt wird, in dem nur die noch verfügbaren Namen angezeigt bzw. gewählt werden können.
Das führt zwar dazu, daß man die Zelle zweimal anklicken muß, dafür spart man sich händische Eingaben und vermeidet damit auch Tippfehler.
Weiterhin färbe ich die Kopfzeile je nach dem, ob alle MA bereits verwurschtelt wurden.
Das Makro greift bis auf weiteres IMMER auf die eine Liste mit MA zu, eigentlich aus Zeitersparnisgründen, was aber den Nachteil hat, daß Urlaube o.ä. nicht berücksichtigt werden. Es ist aber ein Klacks, das so zu ändern, daß wie bisher immer eine MA-Spalte pro Tag verwendet wird.
Das würde dann so aussehen (also z.B. für Tabelle1):
Option Explicit
Const abSp = 7, abZ = 4, bisZ = 9, Nvon = 11, Nbis = 25
Dim liSpLetzte&, letzter As Boolean, aNok As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim bisSp&, liSp&, z&, y&
Dim aEin, aFix, sEin$, sList$
Dim aNamen
bisSp = Cells(3, Columns.Count).End(xlToLeft).Column + 5
If Not Intersect(Target, Range(Cells(abZ, abSp), Cells(bisZ, bisSp))) Is Nothing Then
liSp = Int((Target.Column - 1) / 6) * 6 + 1
If liSp = liSpLetzte Then
If letzter Then
If Not aNok Then aNamen = Range(Cells(Nvon, liSp), Cells(Nbis, liSp)): aNok = True
Cells(abZ - 1, liSp).Resize(, 6).Interior.Color = vbGreen
MsgBox "keiner mehr da"
Exit Sub
End If
Else
aNamen = Range(Cells(Nvon, liSp), Cells(Nbis, liSp)): aNok = True
letzter = False
End If
aEin = Range(Cells(abZ, liSp), Cells(bisZ, liSp + 5))
For z = 1 To UBound(aEin)
For y = 1 To UBound(aEin, 2)
If aEin(z, y) "" Then sEin = sEin & aEin(z, y) & ","
Next
Next
If Trim(Target.Text) "" Then y = 1: sList = Target.Text & "," Else y = 0
For z = 1 To UBound(aNamen)
If InStr(sEin, aNamen(z, 1)) = 0 Then sList = sList & aNamen(z, 1) & ",": y = y + 1
Next
If y > 0 Then sList = Left(sList, Len(sList) - 1)
Range(Cells(abZ, abSp), Cells(bisZ, bisSp)).Validation.Delete ' alle fort, die evtl. da sind
If y
Der Vorteil vom Makro ist, daß es nach rechts offen ist, d.h. wenn Tage hinzukommen, läuft es trotzdem brav weiter.
Allerdings muß man einige Konstanten ändern, falls die Struktur erweitert wird:
abSp = 7 = Spalte G, ab hier stehen Einträge
abZ = 4 = Zeile 4, hier beginnen die Tätigkeiten
bisZ = 9 = unterste Zeile der Tätigkeiten
Nvon = 11 = oberste Zeile mit Namen
Nbis = 25 = unterste Zeile mit Namen.
Schöne Grüße,
Michael