Макрос к таблице

[Dr.House69]

Добрый день! Возникла очередная проблема с начальством, прошу помощи)
Дана таблица из 4 столбцов (начала соответственно с А1, В1,, С1, D1)
В первой колонке фамилии (могут повторяться), во второй слова, в третьей и четвертой даты. Как сделать такой макрос,чтобы при его запуске все таблица преобразовывалась к такому виду, что организовывается поле из трех столбцов для каждой фамилии, в строку пишется фамилия, под ней - слово из второй колонки, напротив него- соответствующие ему даты, и так для всех фамилий, причем если фамилии совпадают, то не создавать еще одно такое поле, а заносить далее. То есть было
Иванов дорога 12 14
Сидоров машина 13 16
Сергеев дорога 15 17
Сидоров путь 15 17
Иванов поезд 13 21

а стало Иванов Сидоров Сергеев
дорога 12 14 машина 13 16 дорога 15 17
поезд 13 21 путь 15 17

[Казанский]

То есть было... а стало...Покажите в файле XLS: файл в архив, Расширенный режим - скрепка...

[Dr.House69]

Сообщение от Казанский

То есть было... а стало...Покажите в файле XLS: файл в архив, Расширенный режим - скрепка...

Вот,прикрепил

[Казанский]

Пробуйте

Sub House69()
Dim u(), x, i&
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
u = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
Rows(1).Insert
Range("A1") = "a"
i = 6
On Error Resume Next
With New Collection
  For Each x In u
  .Add Empty, x
    If Err Then
      Err.Clear
    Else
      Range("A1").AutoFilter 1, x
      Intersect(ActiveSheet.AutoFilter.Range, Range("B:D")) _
        .SpecialCells(xlCellTypeVisible).Copy Cells(2, i)
      Cells(2, i) = x
      i = i + 3
    End If
  Next
End With
ActiveSheet.AutoFilterMode = False
Rows(1).Delete
Application.ScreenUpdating = True
End Sub

[Dr.House69]

Сообщение от Казанский

Пробуйте

Sub House69()
Dim u(), x, i&
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
u = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
Rows(1).Insert
Range("A1") = "a"
i = 6
On Error Resume Next
With New Collection
  For Each x In u
  .Add Empty, x
    If Err Then
      Err.Clear
    Else
      Range("A1").AutoFilter 1, x
      Intersect(ActiveSheet.AutoFilter.Range, Range("B:D")) _
        .SpecialCells(xlCellTypeVisible).Copy Cells(2, i)
      Cells(2, i) = x
      i = i + 3
    End If
  Next
End With
ActiveSheet.AutoFilterMode = False
Rows(1).Delete
Application.ScreenUpdating = True
End Sub

Спасибо огромное! Все работает