Excel VBA для импорта словесных данных в Excel

Question

Я новичок в VBA. Я хочу скопировать таблицы слов в Excel, но я не получаю REQ- часть в Excel, просто получаю другие вкладки

Введите:

Желаемый вывод:

Вывод получаю

Код:

Option Explicit
Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim resultCol As Long
Dim tableStart As Integer
Dim tableTot As Integer
On Error Resume Next
ActiveSheet.Range("A:AZ").ClearContents
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
    tableNo = wdDoc.Tables.Count
    tableTot = wdDoc.Tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If
    resultRow = 2
    For tableStart = 1 To tableTot
        With .Tables(tableStart)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                Range("A1") = "Description"
                Range("A1").Font.Bold = True
                Range("B1") = "Source"
                Range("B1").Font.Bold = True
                Range("C1") = "Rationale"
                Range("C1").Font.Bold = True
                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iCol, iRow).Range.Text)
                Next iCol
                resultRow = resultRow
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With
End Sub

Answer 1

Необходим ряд корректировок, чтобы заставить это работать:

1. On Error Resume Next удалено. Это никогда не должно использоваться для всего макроса - все, что он будет делать, это скрывать ошибки, которые сообщат вам, что происходит не так. Если ошибки происходят регулярно, то нужно что-то исправлять! Это может быть использовано для особых случаев, но обработка ошибок должна быть снова включена. Я не вижу особого случая в этом коде.

2. В Word и Excel используется Range, поэтому важно указать , что означает диапазон . Это также важно в Excel, в одиночку. Использование VBA для предположения , в какой рабочей области находится диапазон, может привести к неожиданным результатам. По этой причине объект Worksheet объявляется и создается для активной рабочей таблицы. Этот объект - ws - затем используется во всем коде для четкой идентификации всех Range объектов в Excel.

3. Поскольку заголовки столбцов в Excel нужно записывать только один раз, этот код был перемещен из цикла. Кроме того, первый столбец не помечен на предоставленном вами снимке экрана (REQ). Поэтому метки должны начинаться со столбца B, а не со столбца A - соответственно, эти координаты диапазона были изменены.

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

5. Остальная часть данных, подлежащих передаче, находится только в столбце 3, поэтому нет необходимости циклически обрабатывать столбцы, только строки. Спецификатор столбца для диапазона Excel был изменен для использования irow + 1, поскольку это дает правильный результат.

6. The Cell() method in Word is: .Cell (rowIndex, colIndex) `- параметры обращаются в код, размещенный в вопросе.

В моих тестах у меня работает следующий код:

Option Explicit

Sub ImportWordTable()
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim tableNo As Integer 'table number in Word
    Dim iRow As Long 'row index in Excel
    Dim iCol As Integer 'column index in Excel
    Dim resultRow As Long
    Dim resultCol As Long
    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim ws As Worksheet

    'On Error Resume Next

    Set ws = ActiveSheet
    ws.Range("A:AZ").ClearContents

    wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
    "Browse for file containing table to be imported")
    If wdFileName = False Then Exit Sub '(user cancelled import file browser)

    Set wdDoc = GetObject(wdFileName) 'open Word file

    With wdDoc
        tableNo = wdDoc.Tables.Count
        tableTot = wdDoc.Tables.Count
        If tableNo = 0 Then
            MsgBox "This document contains no tables", _
            vbExclamation, "Import Word Table"
        ElseIf tableNo > 1 Then
            tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
            "Enter the table to start from", "Import Word Table", "1")
        End If
        resultRow = 2
        With ws
            .Range("B1") = "Description"
            .Range("B1").Font.Bold = True
            .Range("C1") = "Source"
            .Range("C1").Font.Bold = True
            .Range("D1") = "Rationale"
            .Range("D1").Font.Bold = True
        End With
        For tableStart = tableNo To tableTot
            With .Tables(tableStart)
                'copy cell contents from Word table cells to Excel cells
                '''REQ
                ws.Cells(resultRow, 1) = WorksheetFunction.Clean(.Cell(1, 1).Range.Text)
                For iRow = 1 To .Rows.Count
                    'For iCol = 1 To .Columns.Count
                     ws.Cells(resultRow, iRow + 1) = WorksheetFunction.Clean(.Cell(iRow, 3).Range.Text)
                    'Next iCol
                    resultRow = resultRow
                Next iRow
            End With
            resultRow = resultRow + 1
        Next tableStart
    End With
End Sub