Dropdowns via Schlaufe erstellen

Sub Dropdown_A11()
Dim rSource As Range, rDV As Range, r  As Range, csString As String
Dim c As Collection
Set rSource = Sheets("Ressourcengruppen").Range("B2:B1000")
Set rDV = Sheets("Dateneingabe").Range("A11")
Set c = New Collection
csString = ""
On Error Resume Next
For Each r In rSource
v = r.Value
If v  "" Then
c.Add v, CStr(v)
If Err.Number = 0 Then
If csString = "" Then
csString = v
Else
csString = csString & "," & v
End If
Else
Err.Number = 0
End If
End If
Next r
On Error GoTo 0
With rDV.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=csString
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
End Sub