Option Explicit

Sub JoinCodes()
'David McRitchie  http://www.mvps.org/dmcritchie/excel/excel.htm
' 2002-09-12
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim xArg As String, xStr As String, nRow As Long
Dim cell As Range
Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
  nRow = -1
  For Each cell In wsSource.Columns(1) _
       .SpecialCells(xlConstants)
    If nRow = -1 Then
       nRow = nRow + 1
       xArg = Trim(cell.Value)
       xStr = cell.Offset(0, 1).Value
    ElseIf xArg = cell.Value Then
      If Trim(cell.Offset(0, 1)) <> "" Then _
        xStr = xStr & ", " & Trim(cell.Offset(0, 1))
    Else
       nRow = nRow + 1
       wsNew.Cells(nRow, 1) = xArg
       wsNew.Cells(nRow, 2) = xStr
       xArg = Trim(cell.Value)
       xStr = Trim(cell.Offset(0, 1).Value)
    End If
  Next cell
  nRow = nRow + 1
  wsNew.Cells(nRow, 1) = xArg
  wsNew.Cells(nRow, 2) = xStr
done:
   Cells.Select
   Cells.EntireColumn.AutoFit
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True     'place at end when debugged
   Application.DisplayAlerts = True
End Sub