combine records in multiple rows of sheet 1 to sheet 2 based on unique number in column

See the attached file, after running macro consolidate.

Sub Consolidate()
'JBeaucaire  (9/18/2009)
'Columnar data is Sorted/Matched by column A values, merge all other cells into row format
Dim LastRow As Long, NextCol As Long
Dim LastCol As Long, Rw As Long, Cnt As Long
Dim delRNG As Range
Application.ScreenUpdating = False

'Sort data
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
    
'Seed the delete range
    Set delRNG = Range("A" & LastRow + 10)
    
'Group matching names
    For Rw = LastRow To 2 Step -1
        If Cells(Rw, "A").Value = Cells(Rw - 1, "A").Value Then
            Range(Cells(Rw, "B"), Cells(Rw, Columns.Count).End(xlToLeft)).Copy _
                Cells(Rw - 1, Columns.Count).End(xlToLeft).Offset(0, 1)
            Set delRNG = Union(delRNG, Range("A" & Rw))
        End If
    Next Rw

'Delete unneeded rows all at once
    delRNG.EntireRow.Delete (xlShiftUp)
    Set delRNG = Nothing

'Add titles
    NextCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    LastCol = Cells(1, 1).CurrentRegion.Columns.Count
    Range("B1", Cells(1, NextCol - 1)).Copy Range(Cells(1, NextCol), Cells(1, LastCol))

Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub