Hi jindon

It worked on the DummyWorkbook, but when I copy & paste the code to the "real" workbook it breaks (look at the code).

Sub test()
    Dim a, i As Long, txt As String, w, maxCol As Long, e, n As Long
    With Range("A2").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 3) <> "" Then
                    txt = a(i, 1)
                    If Not .exists(txt) Then
                        .Item(txt) = VBA.Array(a(i, 1))
                    End If
                    w = .Item(txt)
                    ReDim Preserve w(UBound(w) + 2)
                    w(UBound(w) - 1) = a(i, 2)
                    w(UBound(w)) = a(i, 3)
                    maxCol = Application.Max(maxCol, UBound(w))
                    .Item(txt) = w
                End If
            Next
            For Each e In .keys
                w = .Item(e)
                If UBound(w) < maxCol Then ReDim Preserve w(maxCol)
                .Item(e) = w
            Next
            w = .items: n = .Count
        End With
        With .Offset(, .Columns.Count + 3).Resize(n, maxCol + 1)
            .CurrentRegion.ClearContents
            .Value = _
            Application.Transpose(Application.Transpose(w))
            If maxCol + 1 > 3 Then
                With .Offset(, 1).Resize(1, 2)
                    .AutoFill .Resize(, maxCol)
                End With
            End If
            .Columns.AutoFit
        End With
    End With
End Sub
It breaks with:
Runtime error '13':
Type mismatch

I'll try to get this correct, but as you already have figured out, I'm not very good at this coding...

Best regards
Lars-Inge