Jess,
Try the macro below, with a blank sheet active.
HTH,
Bernie
MS Excel MVP
Option Explicit
Sub TryNow()
Dim iCol As Integer
Dim ReSortGroup As Boolean
Dim j As Integer
Range("A1").Value = "A Teams"
Range("A2:A17").Formula = "=ROW()-1&""A"""
Range("A1:G1").WrapText = True
Range("B1:G1").Formula = "=""B Teams"" & char(10) & ""Round "" & Column()-1"
Range("B2:B17").Formula = "=ROW()-1&""B"""
With Range("A1:G17")
.Value = .Value
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.HorizontalAlignment = xlCenter
End With
For iCol = 3 To 7
ReSortGroup = True
Range("B2:B17").Copy Cells(2, iCol).Resize(16)
Cells(2, iCol + 1).Resize(16).Formula = "=RAND()"
While ReSortGroup
ReSortGroup = False
Application.Calculate
Cells(2, iCol).Resize(16, 2).Sort key1:=Cells(1, iCol + 1)
For j = 1 To 16
If Application.WorksheetFunction.CountIf(Range(Cells(j + 1, 2), _
Cells(j + 1, iCol)), Cells(j + 1, iCol).Value) > 1 Then
ReSortGroup = True
End If
Next j
Wend
Next iCol
Cells(2, 8).Resize(16).Clear
End Sub