This should get it, works for the sample data at least, adjust ranges to suit:
Dim base        As Dictionary
Dim data        As Variant
Dim x           As Long
Dim totalRows   As Long
Dim a, b, c

Set base = New Dictionary
data = Sheets("sheet1").Range("A2:E7").Value2
Dim keyCount As Long
keyCount = -1


For x = LBound(data) To UBound(data)
    If Not base.Exists(data(x, 1)) And Len(data(x, 1)) > 1 Then
        Set base(data(x, 1)) = New Dictionary
        keyCount = keyCount + 1
        totalRows = totalRows + 1
    ElseIf Len(data(x, 1)) = 0 Then
        If Not base.Exists(data(x, 2)) And Len(data(x, 2)) > 1 Then
           Set base(base.Keys()(keyCount))(data(x, 2)) = New Dictionary
           For y = 3 To UBound(data, 2)
                If (Len(data(x, y)) > 0) Then base(base.Keys()(keyCount))(data(x, 2)).Add x & y, data(x, y)
                totalRows = totalRows + 1
           Next y
        End If
    End If
Next x

ReDim data(1 To totalRows, 1 To 3)
x = 1

For Each a In base.Keys()
    'Debug.Print a
    data(x, 1) = a
    x = x + 1
    For Each b In base(a).Keys()
        'Debug.Print , b
        data(x, 2) = b
        x = x + 1
        For Each c In base(a)(b).Keys()
            'Debug.Print , , c
            data(x, 3) = base(a)(b)(c)
            x = x + 1
        Next c
    Next b
Next a


Sheets(2).Range("a1:c" & totalRows).Value = data
Requires a reference to Microsoft Scripting Runtime, otherwise this requires no references:
Dim base        As Object
Dim data        As Variant
Dim x           As Long
Dim totalRows   As Long
Dim a, b, c

Set base = CreateObject("Scripting.Dictionary")
data = Sheets("sheet1").Range("A2:E7").Value2
Dim keyCount As Long
keyCount = -1


For x = LBound(data) To UBound(data)
    If Not base.Exists(data(x, 1)) And Len(data(x, 1)) > 1 Then
        Set base(data(x, 1)) = CreateObject("Scripting.Dictionary")
        keyCount = keyCount + 1
        totalRows = totalRows + 1
    ElseIf Len(data(x, 1)) = 0 Then
        If Not base.Exists(data(x, 2)) And Len(data(x, 2)) > 1 Then
           Set base(base.Keys()(keyCount))(data(x, 2)) = CreateObject("Scripting.Dictionary")
           For y = 3 To UBound(data, 2)
                If (Len(data(x, y)) > 0) Then base(base.Keys()(keyCount))(data(x, 2)).Add x & y, data(x, y)
                totalRows = totalRows + 1
           Next y
        End If
    End If
Next x

ReDim data(1 To totalRows, 1 To 3)
x = 1

For Each a In base.Keys()
    'Debug.Print a
    data(x, 1) = a
    x = x + 1
    For Each b In base(a).Keys()
        'Debug.Print , b
        data(x, 2) = b
        x = x + 1
        For Each c In base(a)(b).Keys()
            'Debug.Print , , c
            data(x, 3) = base(a)(b)(c)
            x = x + 1
        Next c
    Next b
Next a


Sheets(2).Range("a1:c" & totalRows).Value = data