Option Explicit
Option Base 1

Sub Get_Hierarchy()
'------------------------------------
' Author:    Roman "Rioran" Voronov
' Date:      the 3-rd of September, 2015
' Feedback:  voronov_rv@mail.ru
'------------------------------------
' Programm allows user to define relationships between elements in table format
' where source data consists from two columns with parent and child elements
'------------------------------------
' Программа предназначена для преобразования данных из двух столбцов с зависимостями подчинения
' в табличное представление, где каждый столбец отображает уровень иерархии.
'------------------------------------
      Dim arr_Data          ' Двумерный массив с исходными данными
      Dim arr_Branches      ' Одномерный массив с ветками дерева
      Dim arr_Temp          ' Одномерный массив, равный одной ветке дерева
      Dim arr_Result        ' Двумерный массив с выводимыми результатами
        
      Dim i&, j&, k&        ' Ситуативные итераторы
      Dim lng_DataRows&     ' Количество строк в исходных данных (arr_Data)
      Dim lng_Levels&       ' Количество уровней подчинений в дереве иерархии
      Dim lng_ResultRows&   ' Количество строк в результирующем массиве
      Dim b_Check As Byte   ' Значение для проверок. 1 = True, 0 = False.
        
      ' Задаём исходные данные
      arr_Data = Range("A2:B" & Cells(Cells.Rows.Count, 1).End(xlUp).Row)
      ReDim arr_Branches(1) ' Придаём массиву ветвей исходную форму
      arr_Branches(1) = Array("", "")
      lng_DataRows = UBound(arr_Data, 1)
        
      ' Очистка предыдущих результатов, если есть
      With Cells(1, 4)
          If .Value <> "" Then
              i = .End(xlToRight).Column
              j = .End(xlDown).Row
              Range(Cells(1, 4), Cells(j, i)).Value = ""
          End If
      End With
        
      ' Проверяем корректность структуры иерархии - у каждого узла может быть только 1 родитель
      For i = 1 To lng_DataRows
          For j = i + 1 To lng_DataRows
              If arr_Data(i, 2) = arr_Data(j, 2) Then
                  MsgBox "Есть элементы с двумя главенствующими - иерархия нарушена. Программа прервана."
                  Exit Sub
              End If
          Next j
      Next i
        
      ' Находим уникальные окончания веток дерева иерархии
      k = 1
      For i = 1 To lng_DataRows
          b_Check = 0 ' Обновляем маркер проверки
          For j = 1 To UBound(arr_Branches) ' Перебираем уже собранные уникальные значения
              If arr_Data(i, 2) = arr_Branches(j)(1) Then ' Если одно из них совпадает с текущим
                  b_Check = 1 ' Устанавливаем маркеру значение на пропуск следующего блока
                  Exit For
              End If
          Next j
          If 1 - b_Check Then ' Если у маркера значение ноль
              For j = 1 To lng_DataRows
                  ' Если у узла есть дочерний узел - он нам не подходит
                  If arr_Data(i, 2) = arr_Data(j, 1) Then
                      b_Check = 1
                      Exit For
                  End If
              Next j
              ' Если проверки пройдены - добавляем конечный узел ветки и его родителя
              If 1 - b_Check Then
                  ' В конце массива arr_Branches намеренно 2 одинаковых ветки
                  arr_Branches(k) = Array(arr_Data(i, 2), arr_Data(i, 1))
                  k = k + 1
                  ReDim Preserve arr_Branches(k)
                  arr_Branches(k) = Array(arr_Data(i, 2), arr_Data(i, 1))
              End If
          End If
      Next i
      ReDim Preserve arr_Branches(k - 1) ' Отсекаем излишнюю дублированную ветку
        
      ' Находим пути иерархии каждого конечного узла.
      lng_ResultRows = UBound(arr_Branches)
      For i = 1 To lng_ResultRows
          ReDim arr_Temp(2)
          arr_Temp = arr_Branches(i)
          b_Check = 1
          k = 1
          ' Во временный массив собираем ветку целиком
          Do While b_Check
              For j = 1 To lng_DataRows
                  If arr_Data(j, 2) = arr_Temp(k) Then
                      k = k + 1
                      ReDim Preserve arr_Temp(k)
                      arr_Temp(k) = arr_Data(j, 1)
                      Exit For
                  End If
              Next j
              ' Если конечный родительский узел найден - запрашиваем выход из цикла
              If j = lng_DataRows + 1 Then b_Check = 0
          Loop
          arr_Branches(i) = arr_Temp
          If lng_Levels < UBound(arr_Temp) Then lng_Levels = UBound(arr_Temp)
      Next i
        
      ' Вывод результатов. Каждая ветка прописывается направо от первого столбца arr_Result
      ReDim arr_Result(lng_ResultRows, lng_Levels)
      For i = 1 To lng_ResultRows
          k = 1 ' Для перебора столбцов результата
          For j = UBound(arr_Branches(i)) To 1 Step -1
              arr_Result(i, k) = arr_Branches(i)(j)
              k = k + 1
          Next j
      Next i
      ' Вывод заголовка
      For i = 1 To lng_Levels
          Cells(1, 3 + i).Value = "Level " & (i - 1)
      Next i
      ' Вывод результатов.
      Cells(2, 4).Resize(lng_ResultRows, lng_Levels).Value = arr_Result
End Sub