Multiple awards separate into different columns

[michellemtzr]

Thank you in advance.
I have a spreadsheet with participants winning multiple awards. I want the awards in separate columns tiled Awards 1 Award 2 Award 3....

I have this...

Name	Award
Jane	Gold
Jane	Gold Plus
Mary	Silver
Mary	Broze
Mary	Gold

<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>
</tbody>

I want this

Name	Award 1	Award 2	Award 3
Jane	Gold	Gold Plus
Mary	Silver	Bronze	Gold

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[Joe4]

Welcome to the Board!

Is the data always sorted by Name?

 

[Joe4]

Try this. You can remove the sort part if unnecessary, though it shouldn't hurt anything:

Sub MoveAwards()

    Dim rw As Long
    Dim lc As Long
    Dim c As Long
    
    Application.ScreenUpdating = False
    
'   Enter first row of data after heading
    rw = 2
    
'   Sort data
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    
    Do
'       Exit loop if on last row
        If Cells(rw + 1, "A") = "" Then Exit Do
'       Check to see if value in next row of column A matches current
        If Cells(rw, "A") = Cells(rw + 1, "A") Then
'           Move up value from column B to end of current row
            Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = Cells(rw + 1, "B")
'           Delete row
            Rows(rw + 1).Delete
        Else
'           Move to next row
            rw = rw + 1
        End If
    Loop
    
'   Find last column with data
    lc = Range("A1").SpecialCells(xlLastCell).Column
    
'   Insert award column headings
    For c = 2 To lc
        Cells(1, c) = "Award " & c - 1
    Next c
    
    Application.ScreenUpdating = True
    
End Sub

 

[michellemtzr]

Try this. You can remove the sort part if unnecessary, though it shouldn't hurt anything:


Thank you so much it worked!

 

[michellemtzr]

How would the code change if I had a extra column

I have this

Name	Sport	Award
Jane	Basketball	Gold
Jane	Golf	Gold Plus
Mary	Basketball	Silver
Mary	Basketball	Bronze
Mary	Golf	Gold

<colgroup><col><col><col></colgroup><tbody>
</tbody>

I want this

Name	Sport	Award 1	Award 2
Jane	Basketball	Gold
Jane	Golf	Gold Plus
Mary	Basketball	Silver	Gold
Mary	Golf	Gold

<colgroup><col><col><col span="2"></colgroup><tbody>
</tbody>

 

[Joe4]

Try this:

Sub MoveAwards2()

    Dim rw As Long
    Dim lc As Long
    Dim c As Long
    
    Application.ScreenUpdating = False
    
'   Enter first row of data after heading
    rw = 2
    
'   Sort data by column A and column B
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1"), _
        Order2:=xlAscending, Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
    
    Do
'       Exit loop if on last row
        If Cells(rw + 1, "A") = "" Then Exit Do
'       Check to see if values in next row of column A and B match current
        If (Cells(rw, "A") = Cells(rw + 1, "A")) And (Cells(rw, "B") = Cells(rw + 1, "B")) Then
'           Move up value from column C to end of current row
            Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = Cells(rw + 1, "C")
'           Delete row
            Rows(rw + 1).Delete
        Else
'           Move to next row
            rw = rw + 1
        End If
    Loop
    
'   Find last column with data
    lc = Range("A1").SpecialCells(xlLastCell).Column
    
'   Insert award column headings
    For c = 3 To lc
        Cells(1, c) = "Award " & c - 2
    Next c
    
    Application.ScreenUpdating = True
    
End Sub