Option Explicit

Sub LfdNummern()
Const c_MAX As Integer = 260         'Obergrenze
Dim rngNamen As Range, c As Range
Dim rngNummern As Range, arrDef() As String, x As Long
Dim intRnd As Integer, intNamen As Integer

   'Namen in Spalte C
   Set rngNamen = Range(Cells(5, 3), Cells(Rows.Count, 3).End(xlUp))
   'Prüfung auf Obergrenze
   intNamen = rngNamen.Cells.Count - WorksheetFunction.CountBlank(rngNamen)
   If intNamen >= c_MAX Then
        Call MsgBox("Maximalvorgabe überschritten", vbOKOnly + vbCritical, "Abbruch")
        Exit Sub
   End If
   'Nummernbereich (Ende)
   Set rngNummern = rngNamen.Offset(, -1).Cells(rngNamen.Cells.Count).Offset(1)
   'Ausnahmen
   arrDef = Split(Cells(4, 2).Formula, ",")
   'Nachprüfung
   intNamen = intNamen + UBound(arrDef) + 1
   If intNamen >= c_MAX Then
        Call MsgBox("Maximalvorgabe überschritten", vbOKOnly + vbCritical, "Abbruch")
        Exit Sub
   End If
   'anhängen
   For x = LBound(arrDef) To UBound(arrDef)
      Cells(rngNummern.Row, 2).Offset(x).Value = CInt(arrDef(x))
   Next x
   'Nummernbereich (gesamt)
   Set rngNummern = Range(Cells(5, 2), Cells(Rows.Count, 2).End(xlUp))
   For Each c In rngNamen
      If c.Value <> "" Then
         With rngNummern
          Do
            'eine Zufallszahl
            intRnd = WorksheetFunction.RandBetween(1, c_MAX)
            'bereits benutzt
            If .Find(intRnd, , xlValues, xlWhole) Is Nothing Then
               'eintragen
               c.Offset(, -1).Value = intRnd
               Exit Do
            End If
          Loop
         End With
      End If
   Next c
   'Krücke löschen
   With rngNummern
      For x = LBound(arrDef) To UBound(arrDef)
         Set c = .Find(CInt(arrDef(x)), , xlValues, xlWhole)
         c.Clear
      Next x
   End With
'
End Sub