Option Explicit
Sub GroupTeams()
'ActiveSheet has names in column A and car numbers in C:G
Dim lLastRow As Long
Dim lRowIndex As Long
Dim lColIndex As Long
Dim aryCars(1 To 5) As Variant
Dim lCarIndex As Long
Dim aryData() As Variant
Dim lDataIndex As Long
Dim sCarConCat As String
Dim sOutput As String
Dim sGroup As String
Dim sCurCarGroup As String
Dim sLastCarGroup As String
With ActiveSheet
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Get the last row of data in Column A
For lRowIndex = 2 To lLastRow 'Check each row from row 2 to the last row
sCarConCat = vbNullString 'Clear the varoable that will hold the 5 cars in each row (columns C:G)
'Put a rows' car numbers in array
For lColIndex = 3 To 7
aryCars(lColIndex - 2) = .Cells(lRowIndex, lColIndex)
Next
'Sort 1D array of each row's 5 car numbers low-to-high
BubbleSortArray aryCars
'Concatenate cars so the 5 numbers (now low-to-high), separated by _
commas are put together in a single string named sCarConCat
For lCarIndex = 1 To 5
sCarConCat = sCarConCat & aryCars(lCarIndex) & ","
Next
sCarConCat = Left(sCarConCat, Len(sCarConCat) - 1)
'Name and concatenated car array (sCarConCat) into data array
lDataIndex = lDataIndex + 1
ReDim Preserve aryData(1 To 2, 1 To lDataIndex)
aryData(1, lDataIndex) = .Cells(lRowIndex, 1).Value 'First column in the array holds the name
aryData(2, lDataIndex) = sCarConCat 'Second column in the array holds sCarConCat for that name
Next
End With
'Sort bith columns of the Data Array by the seccond column in the array (sCarConCat) this will group
' the people with the same cars together
Sort2DArray aryData, 2
'Group Names with same sCarConCat string
sCurCarGroup = aryData(2, 1) 'Get the car group for the first name
For lDataIndex = LBound(aryData, 2) To UBound(aryData, 2)
If aryData(2, lDataIndex) = sCurCarGroup Then
'Check the car group of each name. As long as the car group is the same, add the
' player name to the variable sGroup
sGroup = sGroup & aryData(1, lDataIndex) & ", "
Else
'If the car group is different copy the people names and the car group to the sOutput variable
sOutput = sOutput & Left(sGroup, Len(sGroup) - 2) & " with cars " & sCurCarGroup & vbLf
sLastCarGroup = sCurCarGroup 'Save the name of the car group just written to sOutput
sCurCarGroup = aryData(2, lDataIndex) 'save the name of the next car group to sCurCarGroup
sGroup = aryData(1, lDataIndex) & ", " 'save the first player with that car group to the sGroup variable
End If
Next
'If the car group for the last player does not equal the car group just written to sOutput
' save the last player and the last cargroup to sOutput. This will only occur if only 1
' person has the last car group
If sLastCarGroup <> aryData(2, UBound(aryData, 2)) Then
sOutput = sOutput & Left(sGroup, Len(sGroup) - 2) & " with cars " & sCurCarGroup & vbLf
End If
'Display Output
MsgBox sOutput, , "Car Groups"
Debug.Print sOutput
End Sub
Function BubbleSortArray(ary As Variant)
Dim lX As Long, lY As Long
Dim varTemp As Variant
For lX = LBound(ary) To UBound(ary) - 1
For lY = lX + 1 To UBound(ary)
If ary(lX) > ary(lY) Then
varTemp = ary(lY)
ary(lY) = ary(lX)
ary(lX) = varTemp
End If
Next
Next
BubbleSortArray = ary
End Function
Function Sort2DArray(ary2D As Variant, lSortColumn As Long)
Dim lY As Long, lZ As Long
Dim vTemp1 As Variant, vTemp2 As Variant
'Sort ary2D into order
For lY = LBound(ary2D, 2) To UBound(ary2D, 2) - 1
For lZ = lY + 1 To UBound(ary2D, 2)
If ary2D(lSortColumn, lY) > ary2D(lSortColumn, lZ) Then
vTemp1 = ary2D(1, lZ)
vTemp2 = ary2D(2, lZ)
ary2D(1, lZ) = ary2D(1, lY)
ary2D(2, lZ) = ary2D(2, lY)
ary2D(1, lY) = vTemp1
ary2D(2, lY) = vTemp2
End If
Next
Next
Sort2DArray = ary2D
End Function
