This may be hard to do and a deck of cards may be my only answer

In Column A I have a list of names - potentially up to 32 (never any more)

What I need to be able to do is go thru that list and generate 4 even
groups, so for example if there were 20 names in the list it would generate 4
groups of 5 randomly picking the members for each group

The results for each group need to be placed in columns E,I,M,Q starting at
cell 1 in each coumn

If there are 19 people in the group then it would generate 3 of 5 and 1 of 4

Thanks for any assistance

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

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

Try qualifying those ranges:

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

becomes

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

Nigel wrote:

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



--

Dave Peterson

an you explain what this line is doing, I got the code to work but I am
trying to work out how many records it decides to take each time

Thanks

For iCt = 0 To 1

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

Next iCt

"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

After you've qualified the ranges(!)...

The first time through the loop (when iCt = 0), it's equivalent to:
ws1.range("A1:A5").copy _
destination:=ws1.Range("e1")

The second time through the loop (when iCt = 1), it's equivalent to:
ws1.range("A6:A10").copy _
destination:=ws1.Range("i1")



Nigel wrote:

an you explain what this line is doing, I got the code to work but I am
trying to work out how many records it decides to take each time

Thanks

For iCt = 0 To 1

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

Next iCt

"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



--

Dave Peterson

OK now I am gonna sound stupid, but what decides how lines to take, I am
doing a bit of modification that is basically if its 12 rows then split into
6,
if 13 to 18 then 3 groups of 6 and any more of that then spread equally
amonsgt 4 columns

"Dave Peterson" wrote:

After you've qualified the ranges(!)...

The first time through the loop (when iCt = 0), it's equivalent to:
ws1.range("A1:A5").copy _
destination:=ws1.Range("e1")

The second time through the loop (when iCt = 1), it's equivalent to:
ws1.range("A6:A10").copy _
destination:=ws1.Range("i1")



Nigel wrote:

an you explain what this line is doing, I got the code to work but I am
trying to work out how many records it decides to take each time

Thanks

For iCt = 0 To 1

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

Next iCt

"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



--

Dave Peterson

The code I wrote in #2 was for your original specs. The number of
lines it takes is 5, which is hard-coded. If there are 19 names in the
list, it still takes 4 groups of 5. The last one is empty, so you
don't see it. If there were 18 names, the 4th group would get only 3.
The number of groups is also hard-coded to 4 by the '0 to 3' loop
parameters.

Your latest post implies different specs than your original ones. It
calls for potentially a different number of groups and a different
number of names in each one. Obviously that would require some more
flexible VBA code (less hard-coding).

Hth,
Merjet