Sub MatchMaker()
Dim players(), teams(), matches(), team, p1, p2, p3, p4, match As String
Dim playerRange, r As Range
Dim i, j, playerUB, teamUB, matchUB As Long
'getting range where all players are listed...
'i will use this to reference when i need to write stuff
Set playerRange = Range(Range("A2"), Range("A2").End(xlDown))
playerUB = playerRange.count - 1
ReDim players(playerUB)
'i am loading all the player names into an array
For i = 1 To playerRange.count
players(i - 1) = playerRange.Cells(i, 1).Value2
Next i
'creating all the unique teams and loading into an array
'if you have players, A, B, C, D and you need unique teams you see the pattern is...
'AB, AC, AD ... then for B it starts with BC (you already had team BA when you created AB)
'There are two loops here that accomplish this, step through and watch the team names it makes
teamUB = -1
For i = 0 To playerUB - 1
For j = i + 1 To playerUB
team = players(i) & players(j)
playerRange.Cells(teamUB + 2, 1).Offset(0, 3).Value2 = team
teamUB = teamUB + 1
ReDim Preserve teams(teamUB)
teams(teamUB) = team
Next j
Next i
'creating every possible matchup and loading them into an array
'i also check each player to make sure a player isnt on both teams
'the loops are set up the same way as before because that same pattern is need to create all unique combos
matchUB = -1
For i = 0 To teamUB - 1
For j = i + 1 To teamUB
p1 = Left(teams(i), 1)
p2 = Right(teams(i), 1)
p3 = Left(teams(j), 1)
p4 = Right(teams(j), 1)
If Not (p1 = p3 Or p1 = p4 Or p2 = p3 Or p2 = p4) Then
match = teams(i) & teams(j)
playerRange.Cells(matchUB + 2, 1).Offset(0, 4).Value2 = match
matchUB = matchUB + 1
ReDim Preserve matches(matchUB)
matches(matchUB) = match
End If
Next j
Next i
'this is part 2 of the sub... this is where it has to select the matches for the actual matchups
Dim playerMatches(), matchups() As String
Dim matchCounts(), p1Index, p2Index, p3Index, p4Index As Long
Dim pmUB, k, matchCount, muUB, selectedMatch As Long
'create array to store my match counts
'i want to edit the value but not edit the sheet
ReDim matchCounts(playerRange.count)
'i start by getting all the match counts in column 2 next to each player
'make sure match count is the same for every player... this code wont be able to finish
'if for every player you put two matches, but then one player you put one match
'it just isn't possible to satisfy those conditions, so use good values
For i = 0 To playerRange.count - 1
matchCounts(i) = playerRange.Cells(i + 1, 1).Offset(0, 1).Value2
Next i
muUB = -1
'this loop is going to allow me to do something for every player in the array...
'i basically need to go through each player and select the number of matches for him in the counters
'because this code is setup to read a counter from each player, if you put in bad values...
'this code will never finish... every player should use the same match count
For i = 0 To playerUB
pmUB = -1
'get all matches for current player and save in array
'we will randomly select from only matches that include the current player...
'and not entire list
For j = 0 To matchUB
If InStr(matches(j), players(i)) Then
pmUB = pmUB + 1
ReDim Preserve playerMatches(pmUB)
playerMatches(pmUB) = matches(j)
End If
Next j
'now for the current players match count i will add a match to the matchup array
matchCount = matchCounts(i)
For j = 1 To matchCount
'because you want to randomly select matchs AND satisfy some conditions i set this up to try again
'it will randomly select a match that may exceed one players match limit
TryAgain:
'getting index of selected match
selectedMatch = WorksheetFunction.RandBetween(0, pmUB)
'getting players from match
'note this will only work with one character player names
'code needs to be edited for other formats
match = playerMatches(selectedMatch)
p1 = Left(match, 1)
p2 = Right(Left(match, 2), 1)
p3 = Left(Right(match, 2), 1)
p4 = Right(match, 1)
'now check each players match count left and if they have games left...
'then this matchup can be added to the matchup list/array
For k = 0 To playerUB
If players(k) = p1 Then
If matchCounts(k) > 0 Then
p1Index = k
GoTo continue
Else
GoTo TryAgain
End If
End If
If players(k) = p2 Then
If matchCounts(k) > 0 Then
p2Index = k
GoTo continue
Else
GoTo TryAgain
End If
End If
If players(k) = p3 Then
If matchCounts(k) > 0 Then
p3Index = k
GoTo continue
Else
GoTo TryAgain
End If
End If
If players(k) = p4 Then
If matchCounts(k) > 0 Then
p4Index = k
GoTo continue
Else
GoTo TryAgain
End If
End If
continue:
Next k
'so if every player has matches left then decrement the counter in the array for the current player
matchCounts(p1Index) = matchCounts(p1Index) - 1
matchCounts(p2Index) = matchCounts(p2Index) - 1
matchCounts(p3Index) = matchCounts(p3Index) - 1
matchCounts(p4Index) = matchCounts(p4Index) - 1
'write matchup on form
muUB = muUB + 1
ReDim Preserve matchups(muUB)
matchups(muUB) = playerMatches(selectedMatch)
playerRange.Cells(muUB + 1, 1).Offset(0, 5).Value2 = matchups(muUB)
'remove the selected match from the player matches array so it wont get selected again
'i remove from array, then shift everything over and resize the array
pmUB = pmUB - 1
For k = selectedMatch To pmUB
playerMatches(k) = playerMatches(k + 1)
Next k
If pmUB > -1 Then ReDim Preserve playerMatches(pmUB)
Next j
Next i
End Sub
