将Word表格转换为Excel数组

我正在尝试将Word表格转移到Excel中 – 这已经在这里完成了 – 此外，在传输过程中，我只想保留包含特定内容的行，并希望在粘贴到Excel之前重新塑造表格。 我认为这可以通过将每个表格首先转换为Excel数组，然后根据需要修改数组，然后粘贴到指定的范围。 不过，我对Word VBA并不是很熟悉，而且我很难find这个任务。 我从这里的代码开始，我在上面引用的post中find了这个代码。

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 

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

里卡多

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