random team generator for hockey with two sets of data

Hello,

I am trying to build an excel spreadsheet for a hockey program I'm coaching that will do the following:

• Create 4 teams
• There will be a Team 1 White/Dark, and Team 2 White/Dark
• Use 2 lists to distribute players evenly
• There are a disproportionate amount of players on each list. There are 8 Majors, 12 Minors. 2 Majors maximum need to be on every team.
• Every week, the roster will be different (some don't show). I need to be able to hit 'randomize' and exclude certain people, and still have the lines 'relatively' similar

This is an essence two 3 vs 3 games, with a white vs. dark on each side of the ice (2 half-ice games). If there are 3 majors on each side (6 in attendance), one side will have a white with 2 majors, the other side will have a dark with 2 majors.

I'd also like a way to keep track of who's played with/against who, so if I can export that data set to ensure I don't get a duplicate team...or a primarily duplicate team.

can you submit an example workbook with before and after examples.

roster example.xlsx

Please read remarks on each example given. I want to generate these separate Weekly rosters with a randomizer, hence the request for such a script.

Wow that took a lot more effort than I originally anticipated. Should be good to go now. Read my notes in code:

Sub Make_Teams()
Dim ws As Worksheet:    Set ws = Sheets("Sheet1")
Dim wksht As Worksheet
Dim numWeek As Integer, intRandom As Integer, intArrayPos As Integer, numMajors As Integer, arrMajors() As Integer, iArray As Integer
Dim numMinors As Integer, arrMinors() As Integer
Dim rCell As Range

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'   For this to work and make sense to me we are going to utilize multiple worksheets.  Sheet1 will be the data sheet with columns
'   A & B listing the Major and Minor Players available.  Adjust the available names accordingly each week.  When teams are created
'   a new worksheet will be created for that week.  By doing this we can come back later and compare weeks to make sure there are
'   no similar teams.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If Not InStr(1, Sheets(Sheets.Count).Name, "Week") = 0 Then
    numWeek = Right(Sheets(Sheets.Count).Name, 1) + 1
Else
    numWeek = 1
End If

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Week " & numWeek
Set wksht = Nothing
On Error Resume Next
Set wksht = Sheets("Week " & numWeek)
    If wksht Is Nothing Then
        MsgBox ("There has been a critical error in the creation of the next week sheet.  Exiting subroutine.")
        Exit Sub
    End If
On Error GoTo 0

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Create & Format Header

With wksht
    .Range("A1").Value = "TEAM 1 WHITE"
    .Range("B1").Value = "TEAM 1 DARK"
    .Range("C1").Value = "TEAM 2 WHITE"
    .Range("D1").Value = "TEAM 2 DARK"
    .Range("A1:D1").Font.Bold = True
    .Range("A1:D1").EntireColumn.ColumnWidth = 17
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Generate Random Number for Major Players and assign to teams

numMajors = ws.Range("A" & Rows.Count).End(xlUp).Row 'Application.WorksheetFunction.CountA(ws.Range("A2:A" & ws.Range("A" & Rows.Count).End(xlUp).Row)) + 1
ReDim arrMajors(2 To numMajors)
intArrayPos = 2
Do Until intArrayPos > UBound(arrMajors)
    intRandom = Int((numMajors - 2 + 1) * Rnd() + 2)
    On Error Resume Next
    If Not CBool((WorksheetFunction.Match(intRandom, arrMajors, 0))) Then
        arrMajors(intArrayPos) = intRandom
        intArrayPos = intArrayPos + 1
    End If
    On Error GoTo 0
Loop

For iArray = LBound(arrMajors) To UBound(arrMajors)
    For Each rCell In wksht.Range("A1:D10")
        If rCell.Value = "" Then
            rCell.Value = ws.Range("A" & arrMajors(iArray)).Value
            Exit For
        End If
    Next rCell
Next iArray

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Generate Random Number for Minor Players and assign to teams

numMinors = ws.Range("B" & Rows.Count).End(xlUp).Row 'Application.WorksheetFunction.CountA(ws.Range("B2:B" & ws.Range("B" & Rows.Count).End(xlUp).Row)) + 1
ReDim arrMinors(2 To numMinors)
intArrayPos = 2
Do Until intArrayPos > UBound(arrMinors)
    intRandom = Int((numMinors - 2 + 1) * Rnd() + 2)
    On Error Resume Next
    If Not CBool((WorksheetFunction.Match(intRandom, arrMinors, 0))) Then
        arrMinors(intArrayPos) = intRandom
        intArrayPos = intArrayPos + 1
    End If
    On Error GoTo 0
Loop

For iArray = LBound(arrMinors) To UBound(arrMinors)
    For Each rCell In wksht.Range("A1:D10")
        If rCell.Value = "" Then
            rCell.Value = ws.Range("B" & arrMinors(iArray)).Value
            Exit For
        End If
    Next rCell
Next iArray

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Erase arrMajors, arrMinors

End Sub