Question

我正在尝试将Word表格转移到Excel - 这已经完成here - 此外，在转移期间，我只想保留包含某些内容的行，并希望重新整理将表粘贴到Excel之前的表。我认为这可以通过将每个表首先转换为Excel数组然后在将其粘贴到指定范围之前根据需要修改数组来完成。然而，我对Word VBA并不那么熟悉，而且我很难找到这个任务。我从这里的代码开始，我在上面引用的帖子中找到了。

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

我想我应该改变这个块来获得我想要的东西。

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

有人可以帮我吗？如果需要，我可以提供更多细节。非常感谢！

的Riccardo

Answer 1

如果您只想复制某些行：

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

Answer 2

在Tim的帮助下，这是我正在寻找的代码。

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

将Word表转换为Excel数组

2 个答案: