Таблицы... опять таблицы (с картинками)

[dinamitbrein]

Все добрый вечер!
Присылают из другого города вот такую табличку (пример рис.1)
Где позиция адрес почему-то не попала в графу адрес
Изменить они ничегоне могут или не хотят, а началник у меня злой требует чтоб было красиво
Таких файлов приходит много, и позиций там много, замучался уже руками делать!!!
Сидел сегодня целый день, но никак не могу автоматизировать процесс
Не подскажите как сделать? Макросом могу, вижил бейсик не курю.
Если напишите как сделать (подробно) буду очень признателен и если будете в Казани, угощу пивом!!!

Если просто вырзать позицию - таблички сливаются (рис.2)
А надо сделать как в рис.3

Вордовский файл - в архиве чтоб не набирать самому

Всем спасибо!!!

[Stilet]

Да незадача... А вот рисунок справа вверху. Там как-то неоднозначно для товара 2 и 3 адрес написан, такое тоже может быть?

P.S. Казани привет, у меня там знакомая

[dinamitbrein]

там все однозначно
таблица, перевод строки текст, перевод строки, текст

НО в любое место всего документа (в том числе и таблицу) можно засунуть любой символ

[Вождь]

Даю вариант с пересозданием таблиц. Метод имеет свои плюсы и минусы. Выделяем блок таблиц с абзацами адресов и запускаем макрос:

Public Sub Адреса()

Dim R As Word.Range
Dim T As Word.Table
Dim S As Word.Style
Dim C As Long
    
    ' область
    Set R = Selection.Range
    If R.Tables.Count <= 0 Then Exit Sub ' нет таблиц
    R.Expand Unit:=wdTable
    R.Expand Unit:=wdParagraph
    ' формат таблицы
    With R.Tables(1)
        C = .Columns.Count
        Set S = .Style
    End With
    ' таблицы в текст
    For Each T In R.Tables
        T.ConvertToText Separator:=wdSeparateByParagraphs
    Next T
    ' коррекция
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = "(^13)[ ^s^13]{1;}"
        .Replacement.Text = "\1"
    End With
    R.Find.Execute Replace:=Word.wdReplaceAll
    ' текст в таблицу
    Set T = R.ConvertToTable( _
                Separator:=wdSeparateByParagraphs, _
                NumColumns:=C)
    T.Style = S
        
End Sub