Замена текста на таблицу

Sub ConvertTextToTable()
  Dim oTbl As Table 'Переменная для таблицы
  Dim i As Long 'Счётчик
  Application.ScreenUpdating = False 'Отключаем прорисовку экрана, чтобы не мерцал
  With Selection
    .ConvertToTable "|" 'Конвертируем в таблицу
    If .Tables.Count <> 1 Then 'Если в выделении нет таблицы, значит не получилось:(
      MsgBox "Преобразование текста в таблицу не удалось. Попробуйте ещё раз", vbCritical + vbOKOnly, "Преобразование"
      Exit Sub
    End If
    Set oTbl = .Tables(1) 'Запоминаем преобразованную таблицу
  End With
  
  oTbl.Columns.Last.Delete 'Удаляем последний столбец
  oTbl.Columns.First.Delete 'Удаляем первый столбец
  'Перебираем все строки, начиная снизу
  For i = oTbl.Rows.Count To 1 Step -1
    'Если ячейка данной строки в последнем столбце пустая, _
    т.е. содержит только конец абзаца и конец ячейки
    If oTbl.Columns.Last.Cells(i).Range.Text = ChrW(13) & ChrW(7) Then
      oTbl.Rows(i).Delete 'то эту строку удаляем.
    End If
  Next
  'Удаляем лишние пробелы
  oTbl.Range.Find.Execute "  {2;}", MatchWildcards:=True, ReplaceWith:="", Replace:=wdReplaceAll
  'Переводим курсор в первую ячейку последнего столбца
  oTbl.Columns.Last.Cells(1).Range.Select

  With Selection 'Курсор находится в последнем столбце
    .MoveDown
    Do 'Начинаем поиск ячеек для объединения
      'Если в выделении одна ячейка, то расширяем выделение вниз
      If .Information(wdStartOfRangeRowNumber) = .Information(wdEndOfRangeRowNumber) Then .MoveDown Extend:=wdExtend
      If .Cells(.Cells.Count).Range.Text = ChrW(13) & ChrW(7) Then 'Если ячейка пустая
        If .Cells(.Cells.Count).RowIndex <> oTbl.Rows.Count Then 'Если это не последняя ячейка в строке
          .MoveDown Extend:=wdExtend 'Расширяем выделение вниз
        Else
          If .Cells.Count > 1 Then 'Если в выделении более 1 ячейки
            'Создаём вспомогательную закладку, которую помещаем выделенные ячейки
            ActiveDocument.Bookmarks.Add "cells", Selection.Range
            'Объединяем соответствующие ячейки первого столбца
            oTbl.Columns.First.Cells(.Information(wdStartOfRangeRowNumber)).Merge oTbl.Columns.First.Cells(.Information(wdEndOfRangeRowNumber))
            'Выделяем ячейки в последнем столбце
            ActiveDocument.Bookmarks("cells").Range.Select
            'Объединяем ячейки
            .Cells.Merge
          End If
          'Переходим вниз
          .MoveDown
        End If
      Else 'Если ячейка не пустая, т.е. в ней есть номер
        .MoveUp Extend:=wdExtend 'Переходим вверх
        If .Cells.Count > 1 Then 'Если в выделении более 1 ячейки
          'Создаём вспомогательную закладку, которую помещаем выделенные ячейки
          ActiveDocument.Bookmarks.Add "cells", Selection.Range
          'Объединяем соответствующие ячейки первого столбца
          oTbl.Columns.First.Cells(.Information(wdStartOfRangeRowNumber)).Merge oTbl.Columns.First.Cells(.Information(wdEndOfRangeRowNumber))
          'Выделяем ячейки в последнем столбце
          ActiveDocument.Bookmarks("cells").Range.Select
          'Объединяем ячейки в последнем столбце
         .Cells.Merge
        End If
        'Переходим вниз
        .MoveDown
      End If
    Loop While .Information(wdWithInTable) 'Продолжаем цикл, пока курсор находится в таблице
  End With

  'Удаляем лишние абзацы
  oTbl.Range.Find.Execute "^p", ReplaceWith:=" ", Replace:=wdReplaceAll
  'Удаляем лишние пробелы
  oTbl.Range.Find.Execute "  {2;}", MatchWildcards:=True, ReplaceWith:="", Replace:=wdReplaceAll
  'Удаляем вспомогательную закладку
  ActiveDocument.Bookmarks("cells").Delete
  Application.ScreenUpdating = True 'Включаем прорисовку экрана
End Sub