Sub ArrayInDic()
Dim arr(), arrNew(), iDic()
Dim I&, J&, N&, iCount&
Dim mainKey, iKey
On Error Resume Next
With Worksheets("Лист1")
    arr = .Range("A2:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim iDic(2 To 6)
With CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr)
    .Add arr(I, 1), Empty
    If Err <> 0 Then
        For J = 2 To UBound(arr, 2)
            If Not IsEmpty(arr(I, J)) Then iTemp = .Item(arr(I, 1))(J)(arr(I, J))
        Next
        Err.Clear
    Else
        For J = 2 To UBound(arr, 2)
            If Not IsEmpty(arr(I, J)) Then
                Set iDic(J) = CreateObject("Scripting.Dictionary")
                iTemp = iDic(J)(arr(I, J))
            End If
        Next
        .Item(arr(I, 1)) = iDic
    End If
Next
ReDim arrNew(1 To UBound(arr), 1 To 6): I = 1
For Each mainKey In .Keys
    N = I: iCount = 0
    arrNew(I, 1) = mainKey
    For J = 2 To 6
        iCount = IIf(iCount < .Item(mainKey)(J).Count, .Item(mainKey)(J).Count, iCount)
        For Each iKey In .Item(mainKey)(J)
            arrNew(N, J) = iKey: N = N + 1
        Next
        N = I
    Next
    I = I + iCount
Next
End With
Worksheets("Лист1").Range("O2").Resize(I, 6) = arrNew
End Sub