Макрос в Excel для преобразования и переноса таблицы из MS Word

[Natasha_i]

Добрый день.
Не так давно столкнулась с такой задачей. По работе необходимо перенести большой документ (~100 страниц) с таблицами и текстом из Word в Excel. Все бы ничего, это можно сделать и вручную, но есть три проблемы.
1. Между таблицами в Word находится поясняющий текст, который переносить не нужно. Кроме того, в шапке каждой таблицы находится один и тот же текст, который повторять не требуется.
2. Числа в последнем столбце записаны в формате xx xxx.xx и при переносе в Excel, естественно, не воспринимаются как числа. Каждое такое число нужно привести к виду xxxxx,xx, то есть убрать все пробелы и заменить все десятичные разделители - точки на запятые.
3. Таблицы состоят из четырех столбцов, третий столбец переносить не нужно - его нужно удалить либо сразу, либо после переноса в Excel.
Поскольку с макросами имею дело нечасто, попробовала вначале автоматизировать хотя бы часть задачи - изменение чисел в последнем столбце таблицы. Получился такой макрос:

    Sub Replace_Table()
2  Dim oTbl As Table
3  Dim oCell As Cell
4  Dim c As Integer
5
6       Set oTbl = Selection.Tables(1)
7       Set oCell = oTbl.Range.Cells(1)
8       c = oTbl.Columns.Count
9
10
11      Do
12
13        If oCell.ColumnIndex = c Then
14
15            With oCell.Range.Text
16              .Text = "."
17              .Replacement.Text = ","
18            End With
19        Selection.Find.Execute Replace:=wdReplaceAll
20        End If
21        Set oCell = oCell.Next
22        DoEvents
23      Loop Until oCell Is Nothing
24    End Sub

Однако столкнулась с проблемой - оператор With ... End With не работает с переменными типа string. Прошу помочь с этой проблемой, или, если это сложно, натолкнуть на похожий пример.
В приложении находятся пример документа Word и документ Excel, который нужно из него получить. Отформатированы таблицы могут быть по-разному, это не имеет особого значения, но в документе в каждой таблице по 50-100 строк.

[EducatedFool]

оператор With ... End With не работает с переменными типа string

Объявляйте переменную как Variant, или вообще не объявляйте.
И всё будет работать.

А в вашем примере используется не переменная, а ссылка на объект.
Причем вы ошиблись в использовании свойств:
вместо

With oCell.Range.Text
    .Text = "."
    .Replacement.Text = ","
End With

надо написать

With oCell.Range.Find
    .Text = "."
    .Replacement.Text = ","
End With

PS: Вы пишете макрос для Word - поэтому лучше обратиться в соответствующий раздел форума
(поэтому переношу тему из раздела Excel в раздел Word)

[doober]

И у меня получилось 24 строки кода.

[shanemac51]

ТАК КАК В ВОРДЕ ЕСТЬ
-ПРОБЕЛ
-НЕРАЗРЫВНЫЙ ПРОБЕЛ

ОБРАБОТКА НЕСКОЛЬКО ДЛИННЕЕ 24 СТРОК

Public Wd, WDoc
Sub Get_Tables()
          Dim ct As Long, Sh As Worksheet, Filename As String, R, T, S1, S2, J1
          Filename = GetFilePath
        If Filename = "" Then Exit Sub
        ct = 2
        Set Wd = CreateObject("Word.Application")
        Set WDoc = Wd.Documents.Open(Filename)
        Application.ScreenUpdating = False
        ''Application.ThisWorkbook.Worksheets(1).Copy
        ''Set Sh = ActiveSheet
        Set Sh = Excel.Application.ThisWorkbook.ActiveSheet
        With Sh
               For Each T In WDoc.Tables
               For Each R In T.Rows
                   If R.Cells.Count <> 4 Then
                       R.Delete
                   End If
               Next
               For i = 2 To T.Rows.Count
                   .Cells(ct, 1) = Trim(Replace(Replace(T.Rows(i).Cells(1), Chr(13), ""), Chr(7), ""))
                   .Cells(ct, 2) = Trim(Replace(Replace(T.Rows(i).Cells(2), Chr(13), ""), Chr(7), ""))
                   S1 = T.Rows(i).Cells(4)
                   ''.Cells(ct, 4) = S2
                   J1 = Len(S1)
                   If Mid(S1, J1, 1) < Chr(32) Then S1 = Left(S1, J1 - 1)
                   J1 = Len(S1)
                   If Mid(S1, J1, 1) < Chr(32) Then S1 = Left(S1, J1 - 1)
                   S1 = Replace(S1, " ", "")
                   'S1 = Replace(S1, , "")
                   S2 = CCur(S1)
                   .Cells(ct, 3) = S2
                   ct = ct + 1
               Next
            Next
       End With
       WDoc.Close (False)
        Wd.Quit
   Set Wd = Nothing
    Set WDoc = Nothing
      Application.ScreenUpdating = True
End Sub
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для Обработки", _
                     Optional ByVal InitialPath As String = "", _
                     Optional ByVal FilterDescription As String = "Документы Word", _
                     Optional ByVal FilterExtention As String = "*.doc*") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1)
    End With
End Function

[Natasha_i]

Сообщение от doober

И у меня получилось 24 строки кода.

Почти то, что нужно, если не учитывать различие между пробелом и разрывным пробелом. В данном случае получилось следующее:

В том документе почти все числа записаны с использованием неразрывного пробела (кроме одной таблицы в начале). Так что, похоже, для этой конкретной задачи можно заменить пробелы в ней вручную, тогда в коде достаточно будет в строчке

180                   .Cells(ct, 3) = Val(Replace(T.Rows(i).Cells(4), Chr(160), ""))

убрать символ неразрывного пробела.
При запуске макроса, отредактированного shanemac51 выходит ошибка:

Происходит это из-за некорректной обработки чисел - почему-то не убираются пробел и десятичная точка (ccur не может преобразовать в число):

Надо бы подучить VBA, вроде бы простейшая задача, а столько времени тратится на ее решение. Спасибо всем за помощь, сама я бы с этой задачей не справилась.

Только что заметила: достаточно заменить 18 строчку на .Cells(ct, 3) = Val(Replace(T.Rows(i).Cells(4), Chr(160), "")) и макрос корректно обрабатывает и обычные пробелы. Интересно, почему так получается.