Sub Tree()
Dim i&, i_n&, j0&, i1&, i2&, i3&, i_0&, j_n&
Dim Tabl() As String
Dim Der() As String
Dim sovpal As Long
Dim cell As Range
i_n = Cells(Rows.Count, 1).End(xlUp).Row
i_0 = Cells(1, 1).End(xlDown).Row
For Each cell In ActiveSheet.UsedRange
  If j_n < cell.Column Then
    j_n = cell.Column
  End If
Next cell
For i = 1 To 12
Cells(i_0, 3).Resize(i_n - i_0 + 2, j_n - 2).Borders(i).LineStyle = xlNone
Cells(i_0, 3).Resize(i_n - i_0 + 2, j_n - 2).Clear
Next i
ReDim Tabl(2, i_n)
For i = i_0 To i_n
  Tabl(1, i) = Cells(i, 1)
  Tabl(2, i) = Cells(i, 2)
Next i
j0 = 1
ReDim Preserve Der(i_n, 1)
For i1 = 1 To i_n
sovpal = 0
If Tabl(1, i1) <> "" Then
For i = 1 To i_n
  For j = 1 To UBound(Der, 2)
   If Der(i, j) = Tabl(1, i1) Then
      sovpal = sovpal + 1
   End If
  Next j
Next i
If sovpal = 0 Then
    If Tabl(2, i1) = "" Then
       Der(1, 1) = Tabl(1, i1)
       i3 = 1
    Else
       For i = 1 To i_n - 1
          For j = 1 To UBound(Der, 2)
            If Der(i, j) = Tabl(2, i1) Then
               If UBound(Der, 2) < j + 1 Then
                 ReDim Preserve Der(i_n, j + 1)
                 For i2 = i_n - 1 To i + 1 Step -1
                    For j2 = UBound(Der, 2) To j0 + 1 Step -1
                         Der(i2 + 1, j2) = Der(i2, j2)
                         Der(i2, j2) = ""
                    Next j2
                 Next i2
                  i3 = i
               Else
                  i2 = i
                  Do While i2 < i_n
                  For j2 = j To UBound(Der, 2)
                  If Der(i2, j2) <> "" Then
                     i3 = i2
                  End If
                  Next j2
                  If Der(i2 + 1, j) <> "" Then Exit Do
                  i2 = i2 + 1
                  Loop
                 For i2 = i_n - 1 To i3 + 1 Step -1
                    For j2 = UBound(Der, 2) To j0 + 1 Step -1
                         Der(i2 + 1, j2) = Der(i2, j2)
                         Der(i2, j2) = ""
                    Next j2
                  Next i2
               End If
               Der(i3 + 1, j + 1) = Tabl(1, i1)
               i3 = i3 + 1
            End If
          Next j
       Next i
    End If
End If
End If
Next i1
Cells(i_0, 4) = Cells(i_0, 1)
For i = 1 To UBound(Der)
  For j = 1 To UBound(Der, 2)
    If Der(i, j) <> "" Then
       Cells(i + i_0, j + 4) = Der(i, j)
       If i_n < i Then i_n = i
       If j_n < j Then j_n = j
    End If
  Next j
Next i
For i = 7 To 10
  Cells(i_0, 4).Resize(i_n - i_0 + 2, j_n - 3).Borders(i).Weight = xlThin
Next i
End Sub

Sub Tree()
Dim i&, i_n&, j0&, i1&, i2&, i3&, i_0&, j_n&, k&
Dim Tabl() As String
Dim Der() As String
Dim sovpal As Long
Dim cell As Range
i_n = Cells(Rows.Count, 1).End(xlUp).Row
i_0 = Cells(1, 1).End(xlDown).Row
For Each cell In ActiveSheet.UsedRange
If j_n < cell.Column Then
    j_n = cell.Column
End If
Next cell
For i = 1 To 12
Cells(i_0, 3).Resize(i_n - i_0 + 2, j_n - 2).Borders(i).LineStyle = xlNone
Cells(i_0, 3).Resize(i_n - i_0 + 2, j_n - 2).Clear
Next i
ReDim Tabl(3, i_n)
For i = i_0 To i_n
Tabl(1, i) = Trim(Cells(i, 1))
Tabl(2, i) = Trim(Cells(i, 2))
k = k + 1
Tabl(3, i) = k
Next i
k = 0
For i = i_0 To i_n
  If Tabl(1, i) <> "" Then
    j_k = i_0 + k + 1
    For j = j_k To i_n
      If Tabl(1, i) = Tabl(2, j) Then
         k = k + 1
         If i_0 + k > i_n Then Exit For
         Temp1$ = Tabl(1, i_0 + k)
         Temp2$ = Tabl(2, i_0 + k)
         Temp3$ = Tabl(3, i_0 + k)
         Tabl(1, i_0 + k) = Tabl(1, j)
         Tabl(2, i_0 + k) = Tabl(2, j)
         Tabl(3, i_0 + k) = Tabl(3, j)
         Tabl(1, j) = Temp1
         Tabl(2, j) = Temp2
         Tabl(3, j) = Temp3
      End If
    Next j
  End If
Next i
j0 = 1
ReDim Preserve Der(i_n, 2, 1)
For i1 = 1 To i_n
sovpal = 0
If Tabl(1, i1) <> "" Then
For i = 1 To i_n
For j = 1 To UBound(Der, 3)
If Der(i, 1, j) & Der(i, 2, j) = Tabl(1, i1) & Tabl(3, i1) Then
    sovpal = sovpal + 1
End If
Next j
Next i
If sovpal = 0 Then
    If Tabl(2, i1) = "" Then
    Der(1, 1, 1) = Tabl(1, i1)
    i3 = 1
    Else
    For i = 1 To i_n - 1
        For j = 1 To UBound(Der, 3)
            If Der(i, 1, j) = Tabl(2, i1) And Tabl(2, i1) <> "" Then
            If UBound(Der, 3) < j + 1 Then
                ReDim Preserve Der(i_n, 2, j + 1)
                For i2 = i_n - 1 To i + 1 Step -1
                    For j2 = UBound(Der, 3) To j0 + 1 Step -1
                        Der(i2 + 1, 1, j2) = Der(i2, 1, j2)
                        Der(i2 + 1, 2, j2) = Der(i2, 2, j2)
                        Der(i2, 1, j2) = ""
                        Der(i2, 2, j2) = ""
                    Next j2
                Next i2
                i3 = i
            Else
                i2 = i
                Do While i2 < i_n
                For j2 = j To UBound(Der, 3)
                If Der(i2, 1, j2) <> "" Then
                    i3 = i2
                End If
                Next j2
                If Der(i2 + 1, 1, j) <> "" Then Exit Do
                i2 = i2 + 1
                Loop
                For i2 = i_n - 1 To i3 + 1 Step -1
                    For j2 = UBound(Der, 3) To j0 + 1 Step -1
                        Der(i2 + 1, 1, j2) = Der(i2, 1, j2)
                        Der(i2 + 1, 2, j2) = Der(i2, 2, j2)
                        Der(i2, 1, j2) = ""
                        Der(i2, 2, j2) = ""
                    Next j2
                Next i2
            End If
            Der(i3 + 1, 1, j + 1) = Tabl(1, i1)
            Tabl(1, i1) = "" ' убираем повторы
            Tabl(2, i1) = "" ' убираем повторы
            Der(i3 + 1, 2, j + 1) = Tabl(3, i1)
            End If
        Next j
    Next i
    End If
End If
End If
Next i1
Cells(i_0, 4) = Cells(i_0, 1)
For i = 1 To UBound(Der)
For j = 1 To UBound(Der, 3)
    If Der(i, 1, j) <> "" Then
    Cells(i + i_0, j + 4) = Der(i, 1, j)
    If i_n < i Then i_n = i
    If j_n < j Then j_n = j
    End If
Next j
Next i
For i = 7 To 10
Cells(i_0, 4).Resize(i_n - i_0 + 2, j_n - 3).Borders(i).Weight = xlThin
Next i
End Sub