Transforming Word tables into Excel array

问题

I am trying to transfer Word tables to Excel - this has already been done here - and in addition, during the transfer I'd like to keep only rows that contain certain content, and would like to reshape the table before pasting it into Excel. I thought this could be done by converting each table first into an Excel array and then modifying the array as needed before pasting it to a specified range. Yet, I am not so familiar with Word VBA and I am finding this task pretty hard. I am starting from this code here, which I found at the post referenced above.

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 tableStart As Integer
Dim tableTot As Integer

On Error Resume Next

ActiveSheet.Range("A:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.doc", , _
"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
     tableTot = wdDoc.tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    End If


    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
                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With

End Sub

I think I should change this chunk to obtain what I am looking for.

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
                        Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                    Next iCol
                    resultRow = resultRow + 1
                Next iRow
            End With
            resultRow = resultRow + 1
        Next tableStart
    End With

Can someone help me with this? I can provide more details if needed. Many thanks!

Riccardo

回答1:

If you want to copy only certain rows:

For tableStart = 1 To tableTot
    With .tables(tableStart)
        For iRow = 1 To .Rows.Count
            v = WorksheetFunction.Clean(.cell(iRow, 1).Range.Text)
            If v = "A" Or v = "B" Or v = "C" Then
                For iCol = 1 To .Columns.Count
                    Cells(resultRow, iCol) = WorksheetFunction.Clean( _
                                             .cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            End If
        Next iRow
    End With
    resultRow = resultRow + 1
Next tableStart

回答2:

With the help of Tim, this is the code that does what I was looking for.

Sub ImportWordTable()

Dim wdDoc As Object
Dim wdFileName, v, cont 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 tableStart As Integer
Dim tableTot As Integer
Dim rtemp, i As Integer
Dim categ(4), content(4) As Variant
Dim found, temprange As Range

    Worksheets.Add.Name = "tempsht"
    Worksheets.Add.Name = "final"
    With Sheets("final")
    .Cells(1, 1) = "Author"
    .Cells(1, 2) = "Title"
    .Cells(1, 3) = "Date"
    .Cells(1, 4) = "Publication name"
    .Cells(1, 5) = "Word count"
    End With
                categ(0) = "BY"
                categ(1) = "HD"
                categ(2) = "PD"
                categ(3) = "SN"
                categ(4) = "WC"

    resultRow = 2

wdFileName = Application.GetOpenFilename("Word files (*.rtf),*.rtf", , "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
     tableTot = wdDoc.tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    End If


For tableStart = 1 To tableTot - 1
    With .tables(tableStart) 'subset the table and copy it to a tempsheet
        rtemp = 1
        For iRow = 1 To .Rows.Count
            v = WorksheetFunction.Clean(.cell(iRow, 1).Range.Text)
            If v = " HD" Or v = " BY" Or v = " WC" Or v = " PD" Or v = " SN" Or v = "HD" Or v = "BY" Or v = "WC" Or v = "PD" Or v = "SN" Then
                For iCol = 1 To .Columns.Count
                    Sheets("tempsht").Cells(rtemp, iCol) = Trim(WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text))
                Next iCol
                rtemp = rtemp + 1
            End If
        Next iRow

     Set temprange = Sheets("tempsht").Range("A1:A5")

    With temprange
        For i = 0 To 4
            Set found = .find(What:=categ(i))
                If found Is Nothing Then
                    content(i) = ""
                Else
                    content(i) = Sheets("tempsht").Cells(found.Row, 2).Value
                End If
        Next i
    End With
            Sheets("final").Range(Cells(resultRow, 1), Cells(resultRow, 5)) = content
            Sheets("tempsht").Range("A1:B5").ClearContents 'remove content from tempsheet

    End With

    resultRow = resultRow + 1

Next tableStart

    Application.DisplayAlerts = False 'delete temporary sheet
        Sheets("tempsht").Select
    ActiveWindow.SelectedSheets.Delete

End With

End Sub

来源：https://stackoverflow.com/questions/33808852/transforming-word-tables-into-excel-array