Option Explicit
->***
->*** Im Bereich ZuUeberwachenderBereich werden die Zellen
->*** mit einer Gültigkeits-Liste versehen
->***
->*** Die Gültigkeitsliste enthält die Namen, die im Bereich
->*** ZuUeberwachenderBereich noch nicht verwendet werden.
->*** Enthält eine Zelle bereits einen gültigen Namen,
->*** wird der Gültigkeitsliste dieser zelle dieser Name noch
->*** hinzugefügt.
->***
->*** DIESES MAKRO muß in ein Modul der Arbeitsmappe gelegt werden.
->***
->Anleitung:
->
->a) betreffende Excel-Datei öffnen
->b) mit Alt+F11 VB-Editor öffnen
->c) im Project-Fenster VBAProject(betreffende Excel-Datei) selektieren
->d) rechte Maustaste-> einfügen Modul
->e) per Copy and Paste diesen Code einfügen
->f) Speichern (mit Strg+S)
->g) VB-Editor schliessen (mit Alt+Q)
->Name und Bereich des zu überwachenden Blattes
Const c_BlattName = Tabelle1
Public Const ZuUeberwachenderBereich = B5:C14
->Globale Variable
Dim vAlleNamen As Variant
Dim fAusgewaehlteNamen() As String, fAusgewaehlteNamen_cnt As Long
Dim fAnzeigeListe() As String, fAnzeigeListe_cnt As Long
->Default-Wert für Gültigkeits-Liste
Const c_keinNameAusgewaehlt = noch auszuwählen
Sub DropDownListenNamenSetzen()
Dim ws As Worksheet
->*** Feld, das alle Namen aufnimmt
vAlleNamen = Array(Name1, Name2, Name3, Name4, Name5, _
Name6, Name7, Name8, Name9, Name10)
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(c_BlattName)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox Blatt & c_BlattName & nicht vorhanden., vbExclamation
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->*** Bereich auf ausgewählte Namen prüfen
Call AusgewaehlteNamenZusammenstellen(c_keinNameAusgewaehlt, _
fAusgewaehlteNamen(), _
fAusgewaehlteNamen_cnt)
->*** Anzeige Liste Zusammenstellen
Call AnzeigeListeZusammenstellen( _
vAlleNamen, _
fAusgewaehlteNamen(), fAusgewaehlteNamen_cnt, _
c_keinNameAusgewaehlt, _
fAnzeigeListe(), fAnzeigeListe_cnt)
Call GueltigkeitslisteImBereichFuerJedeZelleNeuSetzen( _
ws, ZuUeberwachenderBereich, _
vAlleNamen, _
c_keinNameAusgewaehlt, _
fAnzeigeListe(), fAnzeigeListe_cnt)
AUFRAEUMEN:
Set ws = Nothing
End Sub
Private Function GueltigkeitslisteImBereichFuerJedeZelleNeuSetzen( _
ws As Worksheet, ZuUeberwachenderBereich As String, _
vAlleNamen As Variant, _
c_keinNameAusgewaehlt As String, _
fAnzeigeListe() As String, fAnzeigeListe_cnt As Long)
Dim Zelle As Range, sName As String, sNamensliste As String
Dim x As Long, b_gefunden As Boolean, sEintragListe As String
->Events abschalten
Application.EnableEvents = False
sNamensliste =
For x = 1 To fAnzeigeListe_cnt
If x <> fAnzeigeListe_cnt Then
sNamensliste = sNamensliste & fAnzeigeListe(x) & ,
Else
sNamensliste = sNamensliste & fAnzeigeListe(x)
End If
Next
For Each Zelle In ws.Range(ZuUeberwachenderBereich)
->Namen merken
sName = Zelle.Value
If sName = Or sName = c_keinNameAusgewaehlt Then
Zelle.Value = c_keinNameAusgewaehlt
sEintragListe = sNamensliste
Else
b_gefunden = False
For x = LBound(vAlleNamen) To UBound(vAlleNamen)
If sName = vAlleNamen(x) Then
b_gefunden = True
Exit For
End If
Next
->wenn bereits ein gültiger Name ausgewählt ist,
->dann der Liste hinzufügen
If b_gefunden Then
sEintragListe = sName & , & sNamensliste
Else
sEintragListe = sNamensliste
Zelle.Value = c_keinNameAusgewaehlt
End If
End If
->Fehler abfangen, falls noch keine Validierung vorhanden ist
On Error Resume Next
->Validierung löschen
Zelle.Validation.Delete
On Error GoTo 0
->Validierung neu eintragen
Zelle.Validation.Add Type:=xlValidateList, Formula1:=sEintragListe
Next
AUFRAEUMEN:
->Events anschalten
Application.EnableEvents = True
Set Zelle = Nothing
End Function
Private Function AnzeigeListeZusammenstellen( _
vAlleNamen As Variant, _
fAusgewaehlteNamen() As String, fAusgewaehlteNamen_cnt As Long, _
c_keinNameAusgewählt As String, _
fAnzeigeListe() As String, fAnzeigeListe_cnt As Long)
Dim x As Long, y As Long, b_gefunden As Boolean
->Liste initialisieren
ReDim fAnzeigeListe(1 To 1): fAnzeigeListe_cnt = 0
->nicht ausgewählt an 1. Stelle
fAnzeigeListe_cnt = fAnzeigeListe_cnt + 1
ReDim Preserve fAnzeigeListe(1 To fAnzeigeListe_cnt)
fAnzeigeListe(fAnzeigeListe_cnt) = c_keinNameAusgewählt
->Namen aus AlleNamen in fAnzeigeListe(), wenn nicht bereits ausgewählt
For x = LBound(vAlleNamen) To UBound(vAlleNamen)
b_gefunden = False
For y = 1 To fAusgewaehlteNamen_cnt
If vAlleNamen(x) = fAusgewaehlteNamen(y) Then
b_gefunden = True
Exit For
End If
Next
If Not b_gefunden Then
fAnzeigeListe_cnt = fAnzeigeListe_cnt + 1
ReDim Preserve fAnzeigeListe(1 To fAnzeigeListe_cnt)
fAnzeigeListe(fAnzeigeListe_cnt) = vAlleNamen(x)
End If
Next
End Function
Private Function AusgewaehlteNamenZusammenstellen(c_keinNameAusgewaehlt As String, _
fAusgewaehlteNamen() As String, fAusgewaehlteNamen_cnt As Long)
Dim Zelle As Range
Dim sName As String
->*** füllt die globale Liste AusgewaehlteNamen
->Feld AusgewaehlteNamen initialisieren
fAusgewaehlteNamen_cnt = 0
ReDim fAusgewaehlteNamen(1 To 1)
->zu überwachenden Bereich durchlaufen
For Each Zelle In ActiveSheet.Range(ZuUeberwachenderBereich)
sName = Zelle.Value
If sName <> And sName <> c_keinNameAusgewaehlt Then
->Namen merken
fAusgewaehlteNamen_cnt = fAusgewaehlteNamen_cnt + 1
ReDim Preserve fAusgewaehlteNamen(1 To fAusgewaehlteNamen_cnt)
fAusgewaehlteNamen(fAusgewaehlteNamen_cnt) = sName
End If
Next
AUFRAEUMEN:
Set Zelle = Nothing
End Function
