Перевернуть и разделить. Много

[Sac]

Имеется файл с ~4000 карточками.
Пример 2-ух подряд как в исходном файле прилагаю во вложение.
Поля местами повторяются, местами уникальны. Где-то указан 1 адрес, где-то 3, также и с контактными лицами.

Конвертил в текст (с табами) и под вордом старался разобраться во всех табуляциях (автозаменой пустых ячеек), в итоге всё сильно запуталось.
Прошу помочь в решение моей задачи, как мне их грамотно разделить, перевернув в горизонтальный вид :

название регион город адрес телефон и т.п

Очень на вас надеюсь...

[Sac]

Подмечу, что перевернуть нужно полностью все поля. В плоть до Дилер и часы работы.
На пк есть все версии офиса..если это имеет какое либо значение.

[aval]

Если бы Вы предложили из базы данных заполнить карточки - наверное, Вам бы помогли. А создавать из карточек базу данных - неблагодарная работа... Думаю, здесь таких альтруистов не найдёте.

[Sac]

Очень жаль в этом случае , но надежда умирает последней.
Я ведь не прошу за меня что либо делать , мне нужен лишь "пинок" в нужном направление...

[EducatedFool]

Поля местами повторяются, местами уникальны. Где-то указан 1 адрес, где-то 3, также и с контактными лицами.

Всё зависит от степени "бардака" в исходном файле.
Тут надо смотреть исходный файл, а не выборку из 2 карточек.

В принципе, задача вполне решаема при помощи макросов.
Но, не имея оригинального файла, сделать макрос не получится.

(добавлено)

мне нужен лишь "пинок" в нужном направление...

Отправил файл с макросом на почту.
Надеюсь, этого "пинка" хватит

Вот весь код, который требовался:

Sub Очистка()
    Range([a6], Range("a" & Rows.Count)).EntireRow.ClearContents
End Sub

Sub main()
    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shd.Name Then
            Application.StatusBar = "Обрабатывается лист " & sh.Name: DoEvents
            Set ra = sh.Range(sh.[d1], sh.Range("d" & sh.Rows.Count).End(xlUp))
            For Each cell In ra.SpecialCells(xlCellTypeConstants)
                ОбработатьКарточку cell(4, -2).Resize(100, 13)
            Next cell
        End If
    Next sh
    Application.StatusBar = False
End Sub

Sub ОбработатьКарточку(ByRef ra As Range)
    Dim ro As Range: Set ro = shd.Range("d" & Rows.Count).End(xlUp).Offset(1).EntireRow
    ro.Cells(1) = ra(1, 1): ro.Cells(2) = ra(2, 1)
    ro.Cells(3) = Trim(ra(3, 1)): ro.Cells(4) = Trim(ra(4, 1)): ro.Cells(5) = Trim(ra(5, 1))
    ro.Cells(6) = Trim(ra(7, 1)): ro.Cells(7) = Trim(ra(8, 1)): ro.Cells(8) = Trim(ra(10, 1))
    ro.Cells(9) = "'" & Replace(Trim(ra(11, 1)), "/", "  /  "): ro.Cells(10) = Trim(ra(12, 1))
End Sub