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...

[TABLE="width: 128"]
<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Name[/TD]
[TD="width: 64"]Award[/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Gold[/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Gold Plus[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Silver[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Broze[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Gold[/TD]
[/TR]
</tbody>[/TABLE]


I want this
[TABLE="width: 256"]
<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Name [/TD]
[TD="width: 64"]Award 1[/TD]
[TD="width: 64"]Award 2[/TD]
[TD="width: 64"]Award 3[/TD]
[/TR]
[TR]
[TD]Jane[/TD]
[TD]Gold[/TD]
[TD]Gold Plus[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Silver[/TD]
[TD]Bronze[/TD]
[TD]Gold[/TD]
[/TR]
</tbody>[/TABLE]

 

[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
[TABLE="width: 199"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Sport[/TD]
[TD]Award[/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Basketball[/TD]
[TD]Gold[/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Golf[/TD]
[TD]Gold Plus[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Basketball[/TD]
[TD]Silver[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Basketball[/TD]
[TD]Bronze[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Golf[/TD]
[TD]Gold
[/TD]
[/TR]
</tbody>[/TABLE]


I want this
[TABLE="width: 263"]
<colgroup><col><col><col span="2"></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Sport[/TD]
[TD]Award 1[/TD]
[TD]Award 2[/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Basketball[/TD]
[TD]Gold[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Jane [/TD]
[TD]Golf[/TD]
[TD]Gold Plus[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Basketball[/TD]
[TD]Silver[/TD]
[TD]Gold[/TD]
[/TR]
[TR]
[TD]Mary[/TD]
[TD]Golf[/TD]
[TD]Gold[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[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