Sub Chess( _
  rng_2Columns As Range, _
  cell_Chess As Range)
  'http://www.excelworld.ru/forum/10-44232-1
  ' из первого столбца сделать уникальные заголовки столбцов
  ' из второго столбца накидать по заголовкам уникально

  Dim cell As Range
  
  For Each cell In rng_2Columns.Columns(1).Cells

    Column_Value_Add_if_NOT _
      Column_Head_Find_or_Add(cell_Chess, cell.Value), _
      cell.Offset(0, 1).Value

  Next
End Sub

Function Column_Head_Find_or_Add( _
  cell_01 As Range, _
  sVal As String) _
  As Range
  ' найти или добавить заголовок столбца
  ' вернуть ячейку заголовка

  Dim rng_find As Range
  
  ' заголовков ещё нет
  If cell_01.Value = "" Then
    
    Set rng_find = cell_01
    rng_find.Value = sVal
  
  Else
    
    Dim rng_Heads As Range
    
    ' заголовок одинокая ячейка
    If cell_01.Offset(0, 1).Value = "" Then
      Set rng_Heads = cell_01 ' в заголовках одна ячейка
    Else
      Set rng_Heads = cell_01.Parent.Range(cell_01, cell_01.End(xlToRight))
    End If

    Set rng_find = rng_Heads.Find(sVal)

    If rng_find Is Nothing Then
      ' добавить справа
      Set rng_find = Range_Cell_Right(rng_Heads).Offset(0, 1)

      rng_find.Value = sVal
    
    End If
  End If
  
  Set Column_Head_Find_or_Add = rng_find

End Function

Function Range_Cell_Right( _
  rng As Range) _
  As Range
  ' вернуть правую крайнюю ячейку диапазона

  If rng.Rows(1).Columns.Count = 1 Then

    Set Range_Cell_Right = rng.Rows(1)

  Else
    
    Set Range_Cell_Right = rng.Rows(1).End(xlToRight)
  
  End If
End Function

Function Column_Value_Add_if_NOT( _
  cell_Head As Range, _
  sVal As String)
  ' найти в столбце значение, если нет
  ' добавить вниз
   
  ' ниже заголовка значений пока нет
  If cell_Head.Offset(1, 0).Value = "" Then
    
    cell_Head.Offset(1, 0).Value = sVal

  Else
    
    Dim rng_Columns As Range
    Set rng_Columns = cell_Head.Parent.Range(cell_Head, cell_Head.End(xlDown))
    
    Dim rng_find As Range
    Set rng_find = rng_Columns.Find(sVal)

    If rng_find Is Nothing Then
      
      rng_Columns.End(xlDown).Offset(1, 0).Value = sVal
    
    End If
  End If
End Function