Loop to Rearrange Data

Sub Rearrange()
Dim LastRow As Long, i As Long, iStart As Long, iEnd As Long, j As Long
Application.ScreenUpdating = False
With ActiveSheet
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    iStart = 1
    For i = 1 To LastRow
        If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
            iEnd = i
            j = j + 1
            .Cells(j, 3).Value = Range("A" & iStart).Value
            .Cells(j, 4).Value = Join(Application.Transpose(.Range(.Cells(iStart, 2), .Cells(iEnd, 2))), ", ")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub reorgteams()
Dim e As Range, d As Object, f, x, k As Integer
Set d = CreateObject("scripting.dictionary")
With Range("A:A")
For Each e In .Resize(.Cells(Rows.Count, 1).End(3).Row)
    If Not d.exists(e.Value) Then
        d(e.Value) = e.Value & "," & e.Offset(, 1)
    Else
        d(e.Value) = d(e.Value) & "," & e.Offset(, 1)
    End If
Next e
End With
For Each f In d
    k = k + 1
    x = Split(d(f), ",")
    Cells(k, 3).Resize(, UBound(x) + 1) = x
Next f
End Sub

Sub reorgteams2()
Dim e As Range, d As Object
Set d = CreateObject("scripting.dictionary")
With Range("A:A")
For Each e In .Resize(.Cells(Rows.Count, 1).End(3).Row)
    If Not d.exists(e.Value) Then
        d(e.Value) = e.Offset(, 1)
    Else
        d(e.Value) = d(e.Value) & ", " & e.Offset(, 1)
    End If
Next e
End With
Range("C1").Resize(d.Count, 2) = _
    Application.Transpose(Array(d.keys, d.items))
End Sub

Sub reorgteamsx()
Dim e As Range, d As Object, f, k As Long
Set d = CreateObject("scripting.dictionary")
With Range("A:A")
For Each e In .Resize(.Cells(Rows.Count, 1).End(3).Row)
    If Not d.exists(e.Value) Then
        d(e.Value) = e.Offset(, 1)
    Else
        d(e.Value) = d(e.Value) & ", " & e.Offset(, 1)
    End If
Next e
End With
For Each f In d
    k = k + 1
    Cells(k, 3) = f
    Cells(k, 4) = d(f)
Next f
End Sub