Combining columns into row

Option Explicit
Sub ReorgDataSDPlus()
' hiker95, 08/22/2014, ME762830
Dim r As Long, lr As Long, n As Long, maxn As Long
Dim b As Variant, i As Long, ii As Long, t As Long
Dim rng As Range, c As Range, s, z
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > maxn Then maxn = n
  r = r + n - 1
Next r
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If Not .Exists(c.Value) Then
      .Add c.Value, c.Offset(, 1) & "," & c.Offset(, 2)
    Else
      .Item(c.Value) = .Item(c.Value) & "," & c.Offset(, 1) & "," & c.Offset(, 2)
    End If
  Next
  z = Application.Transpose(Array(.Keys, .Items))
End With
ReDim b(1 To UBound(z, 1), 1 To (maxn * (maxn - 1) + 1))
For i = 1 To UBound(z, 1)
  ii = ii + 1
  b(ii, 1) = z(i, 1)
  If InStr(z(i, 2), ",") = 0 Then
    b(ii, 2) = z(i, 2)
  ElseIf InStr(z(i, 2), ",") > 0 Then
    s = Split(z(i, 2), ",")
    For t = LBound(s) To UBound(s)
      b(ii, t + 2) = s(t)
    Next t
  End If
Next i
Range("E1").Resize(UBound(b, 1), UBound(b, 2)) = b
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Option Explicit
Sub ReorgDataSDPlusV2()
' hiker95, 03/08/2014, ME762830
Dim r As Long, lr As Long, n As Long, maxn As Long
Dim b As Variant, i As Long, ii As Long, t As Long
Dim rng As Range, c As Range, s, z
Dim lc As Long
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  If n > maxn Then maxn = n
  r = r + n - 1
Next r
Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If Not .Exists(c.Value) Then
      .Add c.Value, c.Offset(, 1) & "," & c.Offset(, 2)
    Else
      .Item(c.Value) = .Item(c.Value) & "," & c.Offset(, 1) & "," & c.Offset(, 2)
    End If
  Next
  z = Application.Transpose(Array(.Keys, .Items))
End With
ReDim b(1 To UBound(z, 1), 1 To (maxn * (maxn - 1) + 1))
For i = 1 To UBound(z, 1)
  ii = ii + 1
  b(ii, 1) = z(i, 1)
  If InStr(z(i, 2), ",") = 0 Then
    b(ii, 2) = z(i, 2)
  ElseIf InStr(z(i, 2), ",") > 0 Then
    s = Split(z(i, 2), ",")
    For t = LBound(s) To UBound(s)
      b(ii, t + 2) = s(t)
    Next t
  End If
Next i
Range("F1").Resize(, 3).Value = Range("A1").Resize(, 3).Value
Range("F2").Resize(UBound(b, 1), UBound(b, 2)) = b
lc = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For i = 9 To lc Step 2
  Cells(1, i).Resize(, 2).Value = Cells(1, 2).Resize(, 2).Value
Next i
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
    Dim X0, it, Z, i As Long, LC As Long, ii
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For Each it In Sheets("Sheet1").Columns(1).SpecialCells(2).Offset(1).Resize(Columns(1).SpecialCells(2).Count - 1)
            X0 = .Item(it.Value)
        Next
        Z = .keys
    End With
    With Sheets("Sheet1").Range("A1:C" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
        For i = LBound(Z) To UBound(Z)
            .AutoFilter 1, Z(i)
            Cells(i + 2, 5).Value = Z(i)
            For Each ii In .Offset(1, 1).Resize(.Rows.Count - 1, 2).SpecialCells(12)
                LC = Range("IV" & i + 2).End(xlToLeft).Column
                Cells(i + 2, LC).Offset(, 1).Value = ii.Value
            Next ii
        Next i
        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Sub a_code()
Dim u As Boolean, a, i&, r&, s&, c
a = Cells(1).CurrentRegion.Resize(, 3)

c = a(2, 1): r = 2: s = 5
For i = 3 To UBound(a)
    If a(i, 1) = c Then
        If u = 0 Then Cells(i - 1, 1).Resize(, 3).Copy Cells(r, 5): u = 1
        s = s + 2
        Cells(i, 2).Resize(, 2).Copy Cells(r, s + 1)
        If s > m Then m = s
    Else
        u = 0
        r = r + 1
        s = 5
        c = a(i, 1)
    End If
Next i
Cells(1).Resize(, 3).Copy Cells(5)
For i = 8 To m + 2 Step 2
    Cells(2).Resize(, 2).Copy Cells(i)
Next i
Columns(5).Resize(, m - 2).AutoFit
End Sub

Sub b_code()

Dim b1 As Object, b2 As Object
Dim c, a(), rws&, d&

Set b1 = CreateObject("scripting.dictionary")
Set b2 = CreateObject("scripting.dictionary")
b1.CompareMode = 1: b2.CompareMode = 1
rws = Cells(Rows.Count, 1).End(3).Row
c = Cells(1).Resize(rws, 3)
rws = UBound(c)
ReDim a(1 To rws, 1 To rws)
For d = 2 To rws
    If b1(c(d, 1)) = "" Then b1(c(d, 1)) = b1.Count + 1
    If b2(c(d, 2)) = "" Then b2(c(d, 2)) = b2.Count + 1
    a(b2(c(d, 2)), 1) = c(d, 2)
    a(1, b1(c(d, 1))) = c(d, 1)
    a(b2(c(d, 2)), b1(c(d, 1))) = a(b2(c(d, 2)), b1(c(d, 1))) + c(d, 3)
Next d

Range("E1").Resize(b2.Count + 1, b1.Count + 1) = a
Columns("e").Resize(, b1.Count + 1).AutoFit
End Sub