Sub Draw_4by4()
Dim Result(1 To 4, 1 To 4), Rand, Persons, Dict
Set Dict = CreateObject("scripting.dictionary")
Persons = Range("A1").Resize(4, 6).Value 'read the names of your 24 persons
ReDim Rand(1 To UBound(Persons), 1 To UBound(Persons, 2)) 'make the "Random" array, size equal to "persons"
Range("M1").EntireColumn.ClearContents
For ptr = 1 To 20000
Randomize
For i = 1 To UBound(Rand)
For j = 1 To UBound(Rand, 2)
Rand(i, j) = Rnd() 'fill every element with a random value 0-1
Next
Next
For i = 1 To UBound(Result) 'loop through the persons
a = Application.Index(Rand, i, 0) 'take a row from your RandomArray
For j = 1 To UBound(Result, 2) 'loop for 4 draws of a name in that group
R = Application.Match(WorksheetFunction.Small(a, j), a, 0) 'position of the j-smallest number in that row
Result(i, j) = Persons(i, R) 'that random person
Next
Next
With Range("AA1").Resize(4, 2)
.Value = Application.Transpose(Application.Index(Result, 1, 0))
.Offset(, 1).Resize(, 1).Value = [row(1:4)]
.Sort .Range("A1"), Header:=xlNo
x = Application.Transpose(.Offset(, 1).Resize(, 1).Value)
End With
s = ""
For i = 1 To UBound(x)
s = s & "|" & Join(Application.Transpose(Application.Index(Result, 0, x(i))), ";")
Next
s = Mid(s, 2)
If Not Dict.exists(s) Then
Dict(s) = s
Range("M1").Offset(, 1).Resize(, 3).Value = Array(ptr, Dict.Count, ptr - Dict.Count)
If Dict.Count >= 250 Then Exit For
End If
Range("A1").Offset(, 6).Resize(UBound(Result), UBound(Result, 2)).Value = Result 'write result to sheet
Next
With Range("M1")
.Resize(Dict.Count).Value = Application.Transpose(Dict.keys)
.EntireColumn.AutoFit
.Offset(, 1).Resize(, 2).Value = Array(ptr, Dict.Count)
End With
End Sub