Thanks I get an error message at the line

ws2.Range(Cells(5 * iCt + 1, 1), Cells(5 * iCt + 5, 1)).Copy _
Destination:=ws1.Cells(1, 5 + 4 * iCt)

the message is "Method 'Range' of Object '_Worksheet' failed



"merjet" wrote:

Sub Shuffle()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iCt As Integer
Dim iRow As Integer

Set ws1 = Worksheets("Sheet1") 'list of names in col A
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set ws2 = Worksheets(Worksheets.Count)
iRow = ws1.Range("A1").End(xlDown).Row
ws1.Range("A1:A" & iRow).Copy Destination:=ws2.Range("A1")
ws2.Range("B1:B" & iRow).FormulaR1C1 = "=RAND()"
ws2.Range("A1:B" & iRow).Sort Key1:=ws2.Range("B1"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For iCt = 0 To 3
ws2.Range(Cells(5 * iCt + 1, 1), Cells(5 * iCt + 5, 1)).Copy _
Destination:=ws1.Cells(1, 5 + 4 * iCt)
Next iCt
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
ws1.Activate
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

Hth,
Merjet