random fill

Sub test()
    Dim NameList As Range
    Dim MyName As String
    Dim NameNumber As Integer
    Dim ResultsTable As Range
    Dim NumFound As Boolean
    Dim MyRand As Integer
    '----------------------------------------------
    Set NameList = ActiveSheet.Range("A1:A30")
    Set ResultsTable = ActiveSheet.Range("C1:H5")
    ResultsTable.ClearContents
    '- main loop
    For NameNumber = 1 To 30
        MyName = NameList.Cells(NameNumber, 1).Value
        NumFound = False
        While NumFound = False
            MyRand = Int(Rnd * 30) + 1
            If ResultsTable.Cells(MyRand).Value = "" Then
                ResultsTable.Cells(MyRand).Value = MyName
                NumFound = True
            End If
        Wend
    Next
    MsgBox ("Done")
End Sub

'DATA
'A B C D E
'item found     items left      scenario finding value
'D              A B C E         D
'D B            A C E           B
'D B A          C E             B D A
'D B A C        E               D C
'D B A C E                      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

Option Explicit

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

Application.ScreenUpdating = False
    Set NameList = ActiveSheet.Range("A1:A30")
    mem = NameList
    Set ResultsTable = ActiveSheet.Range("C1:H5")
    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
End Sub

ReDim Arr2(1 To Output.Rows.Count, 1 To 1)

Option Explicit
Option Base 1

Sub transpose()
'Erik Van Geit
'051102

'please set:
'column with sourcedata
'first cell for new range
'number of columns to transpose

'no problem:
'if # of columns is to large
'if the last row will not be filled entirely

Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long
Dim r As Long
Dim rng1 As Range
Dim rng2 As Range

Const col As Integer = 1    'column with source data
Set rng2 = Cells(1, col + 2)    'first cell new range
Const c As Integer = 44     'number of columns

    If Cells(Rows.Count, 1) <> "" Then
    Set rng1 = Range(Cells(1, col), Cells(Rows.Count, col))
    Else
    Set rng1 = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
    End If


r = Int(rng1.Count / c) + 1

ReDim arr2(r, c)
arr1 = rng1

For i = 1 To UBound(arr1)
arr2(Int((i - 1) / c) + 1, IIf(i Mod c, i Mod c, c)) = arr1(i, 1)
Next i

    With rng2
    .Resize(Rows.Count, c).ClearContents
    .Resize(r, c).Value = arr2
    End With

End Sub

Private Sub rnPk(List As Range, Output As Range)
Dim Arr1() As Variant, Arr2() As String
Dim f As Long, i As Long, j As Long
Dim cnt As Long
Arr1 = List
ReDim Arr2(1 To Output.Rows.Count, 1 To Output.Columns.Count)
Randomize
cnt = UBound(Arr1, 1)
For i = 1 To UBound(Arr2, 1)
    For j = 1 To UBound(Arr2, 2)
        f = Int((cnt - LBound(Arr1, 1) + 1) * _
            Rnd + LBound(Arr1, 1))
        Arr2(i, j) = Arr1(f, 1)
        Arr1(f, 1) = Arr1(cnt, 1)
        Arr1(cnt, 1) = Arr2(i, j)
        cnt = cnt - 1
    Next j
Next i
Output.Value = Arr2
End Sub

Sub foo()
Call rnPk([a1:a30], [c1:h5])
End Sub

Sub bar()
Call rnPk([a1:a30], [c1:c30])
End Sub