Option Explicit


Sub tt()
    Dim c As Range
    Dim t0$, t1$, t2$, t3$, t4$, t5$, t$
    Dim d As Object, k, el, i&
    Set d = CreateObject("Scripting.Dictionary"): d.comparemode = 1

    For Each c In [b10].CurrentRegion.Columns(1).Cells
        If c.Font.Bold = False Then
            t = t0 & "|" & t1 & "|" & t2 & "|" & t3 & "|" & t4 & "|" & t5
            If Not d.exists(t) Then d.Add t, New Collection
            'd.Item(t).Add c.Value
            d.Item(t).Add c.Resize(, 9).Value
        Else
            Select Case c.IndentLevel
            Case 0
                t0 = c.Value: t1 = Empty: t2 = Empty: t3 = Empty: t4 = Empty: t5 = Empty: t = Empty
            Case 1: t1 = c.Value
            Case 2: t2 = c.Value
            Case 3: t3 = c.Value
            Case 4: t4 = c.Value
            Case 5: t5 = c.Value
            End Select
        End If
    Next
    If d.Count Then
        Application.ScreenUpdating = False
        With Workbooks.Add(1).Sheets(1)
            For Each k In d.keys
                For Each el In d.Item(k)
                    i = i + 1
                    .Cells(i, 1).Resize(, 5) = Split(k, "|")
                    '.Cells(i, 6) = el
                    .Cells(i, 6).Resize(, 9) = el
                Next
            Next
            .Columns.AutoFit
        End With
        Application.ScreenUpdating = True
    End If
End Sub