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