Loop to Rearrange Data

[ChuckRobert]

I have about 200 rows where column A contains the team name, and column B contains the player name.

Can anyone help me figure how to use a loop to rearrange the data so that only 1 instance of each unique team name from column A is entered to column C, and a string of all player names from column B assigned to the team listed in column A is entered in column D next to the appropraite team now listed in column C?

 

[ChuckRobert]

That version works GREAT with my program! Thanks!!

I was curious if I could make one exception from the Team in column A called "Extras", and post names associated with it from column B vertically into seperate cells in column E instead of the group we just posted in Column C & D.

 

[mirabeau]

Like this?

If you don't want the "Extras" heading in Col E then you can change the two red lines accordingly (delete the first, change the second to E1)

Sub reorgteamsxx()
Dim e As Range, d As Object
Dim f, k As Long, x
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
    If f = "Extras" Then
        x = Split(d(f), ",")
        Range("E1") = f
        Range("E2").Resize(UBound(x) + 1) = Application.Transpose(x)
    Else
        k = k + 1
        Cells(k, 3) = f
        Cells(k, 4) = d(f)
    End If
Next f
End Sub

But Note: This modification also makes use of the Transpose function, which it seems your computer or something at your end may not like. There's workarounds if need be. Just takes another couple of lines of code.

 

[ChuckRobert]

mirabeau,

Thanks so much for lending your time and expertise today! You are my offical "Hero of the Day"! Your code works great!!!

Chuck