Gruppe
Funktion
Problem
In Tabelle E:F soll die Rangfolge aus Tabelle A:C nach Rängen geordnet wiedergegeben werden.
StandardModule: basMain
Sub ZufallsNamen()
Dim rng As Range
Dim var As Variant
Dim iRowL As Integer, iCell As Integer, iCol As Integer
Dim iRow As Integer, iAct As Integer
Dim sName As String
Columns("B:IV").ClearContents
var = Application.InputBox( _
prompt:="Anzahl Gruppen:", _
Default:=6, Type:=1)
If var = "" Then Exit Sub
If Not IsNumeric(var) Then Exit Sub
For iCol = 1 To CInt(var)
Cells(2, iCol + 2) = "Gruppe" & CStr(iCol)
Next iCol
Randomize
iRowL = Range("A1").CurrentRegion.Rows.Count
iRow = 3
iCol = 3
For iCell = 1 To iRowL
iAct = Int((iRowL * Rnd) + 1)
sName = Cells(iAct, 1).Value
Set rng = Range("C2").CurrentRegion.Find( _
what:=sName, lookat:=xlWhole, LookIn:=xlValues)
Do While Not rng Is Nothing
iAct = Int((iRowL * Rnd) + 1)
sName = Cells(iAct, 1).Value
Set rng = Range("C2").CurrentRegion.Find( _
what:=sName, lookat:=xlWhole, LookIn:=xlValues)
Loop
Cells(iRow, iCol) = sName
iCol = iCol + 1
If IsEmpty(Cells(2, iCol)) Then
iRow = iRow + 1
iCol = 3
End If
Next iCell
End Sub