Sub ertert()
Dim tm!: tm = Timer
Dim x, y(), i&, j&, k&, n&, m&

With Sheets("1")
    x = .Range("A1:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim y(1 To UBound(x), 1 To 13): j = 2: k = -1

On Error Resume Next
With New Collection
    For i = 2 To UBound(x, 1)
        If IsEmpty(.Item(x(i, 1))) Then    'код_товара
            j = j + 1: n = j
            .Add j, x(i, 1)
            y(j, 1) = x(i, 1)
        Else
            n = .Item(x(i, 1))
        End If

        If IsEmpty(.Item(x(i, 2))) Then    'код_отдела
            k = k + 3: m = k
            .Add k, x(i, 2)
            If k > UBound(y, 2) Then ReDim Preserve y(1 To UBound(y), 1 To UBound(y, 2) * 2)
            y(1, k) = x(i, 2)
        Else
            m = .Item(x(i, 2))
        End If
        y(n, m) = x(i, 3)
        y(n, m + 1) = x(i, 4)
        y(n, m + 2) = x(i, 5)
    Next i
End With
On Error GoTo 0

y(1, 1) = "код_товара"
Sheets("2").Range("A1").Resize(j, k + 2).Value = y()
MsgBox Timer - tm
End Sub