Option
Explicit
Sub
LfdNummern()
Const
c_MAX
As
Integer
= 260
Dim
rngNamen
As
Range, c
As
Range
Dim
rngNummern
As
Range, arrDef()
As
String
, x
As
Long
Dim
intRnd
As
Integer
, intNamen
As
Integer
Set
rngNamen = Range(Cells(5, 3), Cells(Rows.Count, 3).
End
(xlUp))
intNamen = rngNamen.Cells.Count - WorksheetFunction.CountBlank(rngNamen)
If
intNamen >= c_MAX
Then
Call
MsgBox(
"Maximalvorgabe überschritten"
, vbOKOnly + vbCritical,
"Abbruch"
)
Exit
Sub
End
If
Set
rngNummern = rngNamen.Offset(, -1).Cells(rngNamen.Cells.Count).Offset(1)
arrDef = Split(Cells(4, 2).Formula,
","
)
intNamen = intNamen + UBound(arrDef) + 1
If
intNamen >= c_MAX
Then
Call
MsgBox(
"Maximalvorgabe überschritten"
, vbOKOnly + vbCritical,
"Abbruch"
)
Exit
Sub
End
If
For
x = LBound(arrDef)
To
UBound(arrDef)
Cells(rngNummern.Row, 2).Offset(x).Value =
CInt
(arrDef(x))
Next
x
Set
rngNummern = Range(Cells(5, 2), Cells(Rows.Count, 2).
End
(xlUp))
For
Each
c
In
rngNamen
If
c.Value <>
""
Then
With
rngNummern
Do
intRnd = WorksheetFunction.RandBetween(1, c_MAX)
If
.Find(intRnd, , xlValues, xlWhole)
Is
Nothing
Then
c.Offset(, -1).Value = intRnd
Exit
Do
End
If
Loop
End
With
End
If
Next
c
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