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?

 

[VoG]

Try

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

 

[ChuckRobert]

VoG,
Thanks for the quick reply!

Can you help me understand why I am getting a run-time error '13' type mismatch when it gets to this line?

.Cells(j, 4).Value = Join(Application.Transpose(.Range(.Cells(iStart, 2), .Cells(iEnd, 2))), ", ")

I've formated the columns as General and Text, with andf without links, but still get this error message. Thanks!

 

[VoG]

Do you have headings in row 1?

 

[ChuckRobert]

I don't have any headings on this sheet.

 

[mirabeau]

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

 

[ChuckRobert]

mirabeau,
Thanks! It sorted perfectly, but did paste each player name in its own cell. Do you know how I could I could concatenate the player names within column D using your code?

 

[mirabeau]

easier and shorter this way

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

 

[ChuckRobert]

Thanks for taking another swing at this, however I get a run-time error '13' for type mismatch on this line.

Range("C1").Resize(d.Count, 2) = _
Application.Transpose(Array(d.keys, d.items))

This is the same error message I had when using the Application.Transpose line offered ealier in this thread. Suggestions?

 

[mirabeau]

Funny thing that. I've use that approach to display results many times in the past and never had that error.

I tested this particular code before posting and it gave no error.

I can't reproduce the error so won't spend time trying to analyse it.

But try the following alternative approach and see if it serves you any better.

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