Randomly assigning Groups

Option Explicit
'DATA
'A B C D E
'item found     items left      loops                       possible scenario
'D              A B C E         no extra loops possible     D
'D B            A C E           1/5 chance for extra loop   B
'D B A          C E             2/5 chance for extra loop   B D A
'D B A C        E               3/5 chance for extra loop   D E
'D B A C E                      4/5 chance for extra loop   A A D B E
'this scenario looped 12 times instead of 5

'test looped 500 times the code using random pick
'items      loops
'10         30
'20         60
'30         120
'60         280
'120        650
'since the first items in larger tables will be found quickly the problem is not too big
'but anyway it's a waste

Sub random_teams()
'Erik Van Geit
'051101
'quick random sort
'COLUMN B must be empty

Dim NameList As Range
Dim ResultsTable As Range
Dim mem As Variant
Dim NR As Long

Application.ScreenUpdating = False
    Set NameList = ActiveSheet.Range("A1:A20")
    mem = NameList
    Set ResultsTable = ActiveSheet.Range("C1:G4")
    With NameList
        With .Offset(0, 1)
        .Formula = "=RAND()"
        .Value = .Value
        End With
    .Resize(.Rows.Count, 2).Sort key1:=NameList(1).Offset(0, 1), order1:=1
    .Offset(0, 1).ClearContents
    End With
    
    ResultsTable.ClearContents
    For NR = 1 To NameList.Cells.Count
    ResultsTable.Cells(NR).Value = NameList.Cells(NR, 1).Value
    Next
    
NameList = mem
Application.ScreenUpdating = True

Erase mem
End Sub