Экспорт таблицы из Word в Excel

Sub Main()
'Создание переменных.
Dim Документ As Word.Document
Dim Временный As Word.Document
Dim Таблица As Word.Table, ВрТаблица As Word.Table
'Обращаться к документу будем через переменную Документ,
'так удобнее обращаться и кода меньше писать.
Set Документ = ActiveDocument
'Чтобы не изменить таблицу в документе,
'создадим временный документ и в него скопируем таблицу.
'Там таблицу и будем обрабатывать, а временный документ потом
'закроем без сохранения.
'Visible:=False - временный документ не будет отображать,
'т.к. нет необходимости в этом.
Set Временный = Application.Documents.Add(Visible:=False)
'Поиск таблицы, первая ячейка, которой содержит текст ITEM.
For Each Таблица In Документ.Tables
    'LCase - делает все буквы маленьками (вдруг по каким-то
    'причинам текст ITEM будет маленькими буквами).
    'С помощью InStr определяем, содержится ли в ячейке текст ITEM.
    'Если первая ячейка таблицы содержит текст ITEM, то
    If InStr(LCase(Таблица.Cell(1, 1).Range.Text), "item") > 0 Then
        'Копируем таблицу.
        Таблица.Range.Copy
        'Вставляем скопированную таблицу во временный документ.
        Временный.Range(Start:=0, End:=0).Paste
        'Таблица во временном документе всего одна, поэтому
        'порядковый номер таблицы во временном документе один.
        'Работать с таблицей во временном документе будем через
        'переменную ВрТаблица, чтобы меньше кода писать.
        Set ВрТаблица = Временный.Tables(1)
        'Дальнейшую работу проведём в отдельном коде
        '(чтобы было проще ориентироваться в коде).
        'Call вызывает процедуру.
        'Т.к. предстоит работать с таблицей во временным документом, то
        'процедуре P1 надо сказать, что мы хотим работать с таблицей во
        'временным документом.
        Call P1(ВрТаблица)
        'Удаление знаков Евро и пробелов в последних двух столбцах.
        'Удаление точек из чисел.
        Call P2(ВрТаблица)
        'Объединение ячеек в столбцах 3 и 4.
        Call P3(ВрТаблица)
        'Копируем и вставляем обработанную таблицу в Excel.
        'Передадим ещё процедуре имя документа, чтобы такое же имя
        'файлу Excel.
        Call P4(ВрТаблица, Документ.Name)
        Exit For
    End If
Next Таблица
'Закрытие временного файла без сохранения.
Временный.Close SaveChanges:=wdDoNotSaveChanges
'Сообщение, что работа сделана.
MsgBox "Работа сделана", vbInformation
End Sub

Sub P1(ByRef ВрТаблица As Word.Table)
'Обрабатываем шапки в последних двух столбцах.
'Trim - убирает пробелы.
'С помощью Left берём из ячейки нужное количество символов.
    'Т.к. в каждой ячейки таблицы Word всегда есть 2 непечатаемых символа,
    'то нужно взять текст без этих двух непечатаемых символов.
'С помощью Len определяем количество символов в ячейке.
'Для 5 столбца (предпоследний столбец).
ВрТаблица.Cell(1, 5).Range.Text = _
    Trim(Left(ВрТаблица.Cell(1, 5).Range.Text, Len(ВрТаблица.Cell(1, 5).Range.Text) - 2)) & " " & _
    Trim(Left(ВрТаблица.Cell(2, 5).Range.Text, Len(ВрТаблица.Cell(2, 5).Range.Text) - 2))
'Для 6 столбца (последний столбец).
ВрТаблица.Cell(1, 6).Range.Text = _
    Trim(Left(ВрТаблица.Cell(1, 6).Range.Text, Len(ВрТаблица.Cell(1, 6).Range.Text) - 2)) & " " & _
    Trim(Left(ВрТаблица.Cell(2, 6).Range.Text, Len(ВрТаблица.Cell(2, 6).Range.Text) - 2))
'Удаление второй строки.
ВрТаблица.Rows(2).Delete
End Sub

Sub P2(ByRef ВрТаблица As Word.Table)
'Удаление знаков Евро и пробелов в последних двух столбцах.
'Удаление точек из чисел.
Dim i As Long
'Будем просматривать все ячейки, кроме первой,
'в предпоследнем и последнем столбцах.
'ВрТаблица.Rows.Count - это количество строк в таблице.
'With ... End With - используется, чтобы меньше кода писать.
For i = 2 To ВрТаблица.Rows.Count Step 1
    'Для 5 столбца (предпоследний столбец).
    With ВрТаблица.Cell(i, 5).Range
        'С помощью Replace заменяем знак Евро (код этого символа
        'по таблице ASCII 136) на пустоту (т.е. просто удаляем).
        'С помощью Trim удаляем лишние пробелы.
        .Text = Trim(Replace(Left(.Text, Len(.Text) - 2), Chr(136), ""))
        'Удаление точки из цифры, чтобы в Excel это было число нужного формата.
        .Text = Replace(Left(.Text, Len(.Text) - 2), ".", "")
    End With
    'Для 6 столбца (последний столбец).
    With ВрТаблица.Cell(i, 6).Range
        .Text = Trim(Replace(Left(.Text, Len(.Text) - 2), Chr(136), ""))
        .Text = Replace(Left(.Text, Len(.Text) - 2), ".", "")
    End With
Next i
End Sub

Sub P3(ByRef ВрТаблица As Word.Table)
'Объединение ячеек в столбцах 3 и 4.
Dim i As Long
'Формируем заголовок столбца 3.
ВрТаблица.Cell(1, 3).Range.Text = "DESCRIPTION, MOD."
For i = 2 To ВрТаблица.Rows.Count Step 1
    'В каждой ячейке таблицы Word всегда есть 2 символа.
    'Если в ячейке больше двух символов, значит в этой ячейке есть данные.
    'С помощью Trim уберём случайные пробелы, т.к. пробелы считаются тоже символами.
    'Trim не убирает неразрывные пробелы.
    If Len(Trim(ВрТаблица.Cell(i, 4).Range.Text)) > 2 Then
        ВрТаблица.Cell(i, 3).Range.Text = _
            Left(ВрТаблица.Cell(i, 3).Range.Text, Len(ВрТаблица.Cell(i, 3).Range.Text) - 2) & _
            ", mod. " & _
            Trim(Left(ВрТаблица.Cell(i, 4).Range.Text, Len(ВрТаблица.Cell(i, 4).Range.Text) - 2))
    End If
Next i
'Удаляем столбец 4.
ВрТаблица.Columns(4).Delete
End Sub

Sub P4(ByRef ВрТаблица As Word.Table, Имя As String)
'Копируем и вставляем обработанную таблицу в Excel.
'Сохранение Excel.
Dim Эксель As New Excel.Application
Dim Книга As Excel.Workbook
Dim Массив() As String
'Копирование таблицы из временного файла Word.
ВрТаблица.Range.Copy
'Чтобы программу Excel было видно.
Эксель.Visible = True
'xlWBATWorksheet - создаёт только один лист Excel.
Set Книга = Эксель.Workbooks.Add(Template:=xlWBATWorksheet)
'Вставка скопированного из Word в Excel.
Книга.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
'Имя получаем с расширением документов Word.
'Поэтому расширение надо убрать. В именах файлов не может быть точек,
'поэтом для ориентира можно использовать точку в расширении.
'Получим массив состоящий из двух элементов:
'часть до точки и часть после точки.
Массив = Split(Имя, ".")
'Возьмём часть до точки (элементы массива нумеруются
'по умолчанию с нуля, поэтому порядковый номер
'первого элемента массива будет ноль).
Имя = Массив(0)
With Эксель.FileDialog(msoFileDialogSaveAs)
    .AllowMultiSelect = False
    .ButtonName = "Сохранить"
    .InitialFileName = Имя
    .Title = "Сохранение документа"
    '-1 - означает, что нажата кнопка "Сохранить".
    If .Show = -1 Then
        .Execute
    End If
End With
End Sub