Abgleich in Abhängigkeit mehrerer Spalten #2 (Piet

Hallo Benjamin
ich freue mich dir eine m.E. funktionierende Lösung anbieten zu können, es fehlt noch der  _
Praxis Test!
Der Code gehört in ein normales Modul, und im Target Makro in Tebelle Planung gehört noch der  _
Call Befehl hinein.
In Tabelle "Planung" muss nur der Anfangsteil im Code geaendert werden, s.unten! (Target!)
Im Prinzip ist es dasselbe Makro wie in Planung, nur auf eine For Nex schleife umprogrammiert.  _
Bei mir habe ich einen CommandButton eingefügt, kann dieses Makro zur Kontrolle einer ganzen Spalte auch von Hand starten. Findet es keinen fehler erfolgt nur die Anzeige "Mehrfach Test aktiv", sonst geschieht nichts. Findet es Mitarbeiter die es nicht gibt wird dieser Eintrag rot markiert. Du kannst ihn auch löschen lassen. Ansonsten erfolgt die normale Prüfung wie gehabt.
Diese Idee ist neu, bisher in der Praxis nicht getestet. Würde mich freuen wenn es so klappt!
mfg Piet

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich1 As Range, Verfuegbar As Range
Dim Spalte As Integer, lz As Long
'** neu eingefügt:  mehrfach Test bei kopieren von Mitarbeitern
If Target.Cells.Count > 1 Then Call Verfügbarkeit_mehrfach_Test
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

Option Explicit
'Mehrfach Test nach kopieren über For Next
Sub Verfügbarkeit_mehrfach_Test()
Dim Bereich1 As Range, Verfuegbar As Range
Dim Spalte As Integer, lz As Long
Dim AC As Range, Zahl As Variant
'Aussprung wenn keine Mitarbeiter Spalte vorliegt!!
If Selection.Columns.Count > 1 Then Exit Sub
Spalte = Selection.Column  'Spalte als Index laden
If Cells(3, Spalte)  "Mitarbeiter" Then Exit Sub
'nur Bereich Zeile 4 - 135 zum Prüfen zulaessig!!
Zahl = Mid(Selection.Address, InStrRev(Selection.Address, "$") + 1, 10)
If Zahl  135 Then Exit Sub
MsgBox "Mehrfach Test aktiv"   '** kann gelöscht werden
'** lz aus Spalte-1 laden, sonst fehlen Mitarbeiter!!
lz = Cells(Rows.Count, Spalte - 1).End(xlUp).Row
Set Bereich1 = Range(Cells(4, Spalte), Cells(135, Spalte))
Set Verfuegbar = Range(Cells(142, Spalte - 1), Cells(lz, Spalte))
'Prüfung aller kopiewrten Mitarbeiter über For Next Schleife
If Not Bereich1 Is Nothing Then
For Each AC In Selection
If AC.Value  Empty Then
'** neu - Vorprüfung ob Mitarbeiter überhaupt existiert!!
If WorksheetFunction.CountIf(Verfuegbar, AC.Value) = 0 Then
MsgBox AC.Value & " - diesen Mitarbeiter gibt es Nicht!"
AC.Font.ColorIndex = 3  'markieren oder löschen!!
'AC.Value = Empty       'mit Empty wird gelöscht!
End If
If WorksheetFunction.CountIf(Bereich1, AC.Value) > 1 Then
MsgBox AC & " -  Doppelter Eintrag nicht zulässig"
Application.EnableEvents = False
AC.Value = ""
Application.EnableEvents = True
AC.Select
Set Bereich1 = Nothing
Exit Sub
End If
If Verfuegbar.Find(AC.Value).Offset(0, 1) = "krank" Then
MsgBox AC & " -  Mitarbeiter ist krank gemeldet"
Application.EnableEvents = False
AC.Value = ""
Application.EnableEvents = True
AC.Select
ElseIf Verfuegbar.Find(AC.Value).Offset(0, 1) = "Ausbildung" Then
MsgBox AC & " -  Mitarbeiter ist auf Schulung"
Application.EnableEvents = False
AC.Value = ""
Application.EnableEvents = True
AC.Select
ElseIf Verfuegbar.Find(AC.Value).Offset(0, 1) = "Urlaub" Then
MsgBox AC & " -  Mitarbeiter ist auf Schulung"
Application.EnableEvents = False
AC.Value = ""
Application.EnableEvents = True
AC.Select
ElseIf Verfuegbar.Find(AC.Value).Offset(0, 1) = "geplant" Then
MsgBox Ac &  " -  Mitarbeiter ist bereits geplant"
Application.EnableEvents = False
AC.Value = ""
Application.EnableEvents = True
AC.Select
Else
'nix machen
End If
End If  'For Next
Next AC
End If
Set Bereich1 = Nothing
Set Verfuegbar = Nothing
End Sub