creating groups from an existing list

[joe the soccer dude]

Hello
My question is quite simple but i have no idea on how to go about it.I hope
that you guys will be able to assist.
We a community based soccer club and we run soccer festivals for kids on a
regular basis. My main problem is that we need to place these kids into
random groups. I have approximately 300 kids data on a spreadsheet with all
their particulars. What we normally do is manually put the kids names on a
seperate sheet into groups. I have 50 groups with 6 kids in each group. Is it
possible to be able to at the click of a button export just the name and
surname from sheet 1 into the grouops that i have created in sheet 2.

 

[Ryan H]

Sure that is possible. But we need to know more about how your Sheets are
arranged. For example, is your sheet1 like this

A B C
1 Group 1 Group 2 ...
2 Ryan Chris
3 Kevin Todd
4 Sam Brian
5 George Jim
6 Juan Jorge

or like this
A B C D
1 Group 1 Ryan Kevin Sam...
2 Group 2 Chris Todd Brian ....

Just describe the name and surname column locations.

 

[joe the soccer dude]

my spread sheet with the data is as follows
A B C D ETC
------------------------------------------------------------------
NO NAME SURNAME TELE
1 JOE XXXX 1111-1111
2 RYAN YYYYY 2222-333

IT GOES ON LIKE THIS TILL 300

FROM THIS INFORMATION I WANT TO TRANSFER IT INTO ANOTHER SHEET THAT LOOKS
LIKE THIS

NO NAME SURNAME
1
2
3
4
5
6

I HAVE 50 OF THESE GROUPS LIKE THIS SO FROM 1 TO 300 NEEDS TO POPULATE
THESE GROUPS MAYBE I COULD EMAIL YOU MY WORKBOOK AND YOU COULD HAVE A LOOK AT
IT HOW I HAVE IT CURRENTTLY

 

[Ryan H]

Sure e-mail it to:

(e-mail address removed)

 

[Ryan H]

Put this code in a standard module and then add a Forms control button
wherever you want in the workbook and assign this macro to it. If this post
helps please click "YES" below. Thanks!

Option Explicit

Sub CompileTeams()

Dim LastRow As Long
Dim Teams As Collection
Dim Team As Range
Dim i As Long

Application.ScreenUpdating = False

With Sheets("Player Particulars")

' find last player
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row

' sort Column B to shuffle players
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("B4:B" & LastRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Sheets("Player Particulars").Rows("4:" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

' collect team ranges
Set Teams = New Collection
With Teams
.Add Sheets("TEAMS").Range("B4:C9")
.Add Sheets("TEAMS").Range("F4:G9")
.Add Sheets("TEAMS").Range("J4:K9")
.Add Sheets("TEAMS").Range("N4:O9")
.Add Sheets("TEAMS").Range("R4:S9")
.Add Sheets("TEAMS").Range("B12:C17")
.Add Sheets("TEAMS").Range("F12:G17")
.Add Sheets("TEAMS").Range("J12:K17")
.Add Sheets("TEAMS").Range("N12:O17")
.Add Sheets("TEAMS").Range("R12:S17")
.Add Sheets("TEAMS").Range("B20:C25")
.Add Sheets("TEAMS").Range("F20:G25")
.Add Sheets("TEAMS").Range("J20:K25")
.Add Sheets("TEAMS").Range("N20:O25")
.Add Sheets("TEAMS").Range("R20:S25")
.Add Sheets("TEAMS").Range("B28:C33")
.Add Sheets("TEAMS").Range("F28:G33")
.Add Sheets("TEAMS").Range("J28:K33")
.Add Sheets("TEAMS").Range("N28:O33")
.Add Sheets("TEAMS").Range("R28:S33")
.Add Sheets("TEAMS").Range("B36:C41")
.Add Sheets("TEAMS").Range("F36:G41")
.Add Sheets("TEAMS").Range("J36:K41")
.Add Sheets("TEAMS").Range("N36:O41")
.Add Sheets("TEAMS").Range("R36:S41")
.Add Sheets("TEAMS").Range("B53:C58")
.Add Sheets("TEAMS").Range("F53:G58")
.Add Sheets("TEAMS").Range("J53:K58")
.Add Sheets("TEAMS").Range("N53:O58")
.Add Sheets("TEAMS").Range("R53:S58")
.Add Sheets("TEAMS").Range("B61:C66")
.Add Sheets("TEAMS").Range("F61:G66")
.Add Sheets("TEAMS").Range("J61:K66")
.Add Sheets("TEAMS").Range("N61:O66")
.Add Sheets("TEAMS").Range("R61:S66")
.Add Sheets("TEAMS").Range("B69:C74")
.Add Sheets("TEAMS").Range("F69:G74")
.Add Sheets("TEAMS").Range("J69:K74")
.Add Sheets("TEAMS").Range("N69:O74")
.Add Sheets("TEAMS").Range("R69:S74")
.Add Sheets("TEAMS").Range("B77:C82")
.Add Sheets("TEAMS").Range("F77:G82")
.Add Sheets("TEAMS").Range("J77:K82")
.Add Sheets("TEAMS").Range("N77:O82")
.Add Sheets("TEAMS").Range("R77:S82")
End With

' fill teams
i = 4
For Each Team In Teams
Team.Value = .Range(.Cells(i, "C"), .Cells(i + 5, "D")).Value
i = i + 6
Next Team

' reorganize players
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A4:A" & LastRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Sheets("Player Particulars").Rows("4:" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

' select next available player opening
.Activate
.Range("C" & LastRow + 1).Select
Sheets("TEAMS").Activate
End With

Application.ScreenUpdating = True

End Sub