Hallo allerseits,
vor längerer Zeit hat man mir hier mit Code geholfen um automatisch Dropdownlisten in einer Tabelle hinzuzufügen bzw. zu entfernen. Nun wollte ich diesen erweitern und habe was geändert, aber er läuft nicht . Bekomme aber auch keine Fehlermeldung -.- Hier ist ein Auszug...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Shows dropdown entries for reference columns
Application.EnableEvents = False
On Error GoTo ErrHandler
Dim rngRef As Excel.Range
Dim rngArea As Excel.Range
Dim rngCells As Excel.Range
Dim rngCell As Excel.Range
Set rngRef = ActiveSheet.UsedRange.Columns
' react only to changes within the following range
Select Case rngRef
Case Is = "C"
' check for changes
Set rngCells = Intersect(Target, rngRef)
If Not rngCells Is Nothing Then
For Each rngArea In rngCells.Areas 'relevant for simultaneous change within several cells
For Each rngCell In rngArea.Cells
With Cells(rngCell.row, "D") 'cell with dropdown list
If Trim$(rngCell.Value) <> "" Then
'> changed cell contains data => delete dropdown content and set new one
Call .Validation.Delete
Call .ClearContents
Call .Validation.Add(xlValidateList, Formula1:="=Drivers")
Else
'changed cell contains data => delete dropdown and content
Call .Validation.Delete
Call .ClearContents
End If
End With
Next
Next
End If
Vielen Dank für die Hilfe & schon mal ein schönes Wochenende!
Viele Grüße
|