Option
Explicit
Dim
arrDef()
As
String
Dim
arrNamen()
As
Variant
Sub
Nummerieren()
Dim
rngNamen
As
Range, c
As
Range
Dim
rngNummern
As
Range, x
As
Long
, y
As
Long
Dim
intRnd
As
Integer
, intNamen
As
Long
Dim
intStart
As
Integer
, intx
As
Integer
arrDef = Split(Cells(4, 2).Formula,
","
)
Set
rngNamen = Range(Cells(5, 3), Cells(Rows.Count, 3).
End
(xlUp))
intNamen = rngNamen.Cells.Count - WorksheetFunction.CountBlank(rngNamen)
ReDim
arrNamen(1
To
intNamen, 1
To
2)
For
Each
c
In
rngNamen
If
c.Value <>
""
Then
y = y + 1
arrNamen(y, 1) = c.Row
Do
x = x + 1
If
IsDef(x) =
False
Then
arrNamen(y, 2) = x
Exit
Do
End
If
Loop
End
If
Next
c
Mischen
Eintragen
End
Sub
Private
Sub
Eintragen()
Dim
j
As
Long
Dim
lngAlt
As
Long
, lngRnd
As
Long
For
j = LBound(arrNamen)
To
UBound(arrNamen)
Cells(arrNamen(j, 1), 2).Value = arrNamen(j, 2)
Next
j
End
Sub
Private
Sub
Mischen()
Dim
j
As
Long
Dim
lngAlt
As
Long
, lngRnd
As
Long
For
j = LBound(arrNamen)
To
UBound(arrNamen)
lngAlt = arrNamen(j, 2)
lngRnd = WorksheetFunction.RandBetween(LBound(arrNamen), UBound(arrNamen))
arrNamen(j, 2) = arrNamen(lngRnd, 2)
arrNamen(lngRnd, 2) = lngAlt
Next
j
End
Sub
Private
Function
IsDef(
ByVal
Zahl
As
Long
)
As
Boolean
Dim
i
As
Long
For
i = LBound(arrDef)
To
UBound(arrDef)
If
Zahl =
CLng
(arrDef(i))
Then
IsDef =
True
Exit
Function
End
If
Next
i
IsDef =
False
End
Function