Hallo,

ich will eine Liste von Messmittels für unsere Techniker in Excel erstellen, bei der Mann ab der Zelle D3 mehrere Messmittel auswählen kann (im Tab Messmittel hinterlegt) und diese dann nicht mehr auswählbar sind wenn man ein Messmittel in D3 ausgewählt hat oder das ausgewählte Messmittel farbig wird.

Die Dropdownliste hätte ich ja noch hinbekommen, die Mehrfachauswahl leider wegen mangelnder Kenntnis in VBA nur noch nach langem suchen im Netz.

Die angehängte Datei hat schon ne VBA-Programmierung (in "Berechnung" mit Rechtsklick startet man), nur funktioniert da das Färben/Weglassen/Nicht auswählbar nicht für schon ausgewählte Messmittel.
Ich will alle Messmittel z. B. von Techniker 1 in Zelle D3 haben, die von Techniker 2 in D4 usw.
So wie es mit der Programmierung momentan geht, aber schon ausgewählte Messmittel, welche auch nur einmal verfügbar sind für alle Techniker sollten dann nicht mehr auswählbar sein.

Das Ganze ist über eine UseForm mit Button und Listbox programmiert. Nur das mit dem Auswählen ist noch offen.

Ich hoffe alles verständlich erklärt zu haben und danke schon einmal im Voraus

Gruß 

Bei Bedarf, könnte ich die Excel-Datei zur Verfügung stellen.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Columns(4)) Is Nothing Then
  Cancel = True
  UserForm1.Show
End If

'** Dimensionierung der Variablen
Dim rngDV As Range
Dim wert_old As String
Dim wertnew As String

'** Errorhandling
On Error GoTo Errorhandling

'** Mehrfachauswahl im definierten Bereich (Bsp. D3:D20) durchführen
If Not Application.Intersect(Target, Range("D3:D150")) Is Nothing Then

'**Range definieren
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling

'** Prüfen, ob eine gültige Zelle ausgewählt wurde und Werte eintragen
If Not Application.Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
wertnew = Target.Value
Application.Undo
wertold = Target.Value
Target.Value = wertnew
If wertold <> "" Then
If wertnew <> "" Then
Target.Value = wertold & ", " & wertnew
End If
End If
End If
Application.EnableEvents = True
End If

Errorhandling:
Application.EnableEvents = True
End Sub



Private Sub CommandButton1_Click()
 Dim strTxt As String
 Dim i As Integer
  With ListBox1
  For i = 0 To .ListCount - 1
   If .Selected(i) Then strTxt = strTxt & ", " & .List(i)
  Next
 End With
 ActiveCell = Mid(strTxt, 3)
 Unload Me
End Sub

Private Sub UserForm_Initialize()
 With ListBox1
  .List = Worksheets("Messmittel").Range("A1:A34").Value
  .ListStyle = fmListStyleOption
  .MultiSelect = fmMultiSelectMulti
 End With
End Sub