在Excel VBA中保留Word表格的格式

Question

从另一次讨论中，我找到了从Word导入表格到Excel的宏。

它很好用，但我怎样才能让它保持Word表的格式？

我已经尝试了几种方法，但不能完全得到它的工作。还有一种方法可以一次执行多个文件，而不是每次执行一个文件？

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 (*.doc),*.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 
    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 = 4 

    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 

Answer 1

使用同一目录中多个文档的格式复制表格。

Sub ImportWordTable() 

    Dim WordApp As Object 
    Dim WordDoc As Object 
    Dim arrFileList As Variant, FileName As Variant 
    Dim tableNo As Integer       'table number in Word 

    Dim tableStart As Integer 
    Dim tableTot As Integer 
    Dim Target As Range 

    'On Error Resume Next 

    arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _ 
               "Browse for file containing table to be imported", , True) 

    If Not IsArray(arrFileList) Then Exit Sub   '(user cancelled import file browser) 

    Set WordApp = CreateObject("Word.Application") 
    WordApp.Visible = True 

    Range("A:AZ").ClearContents 
    Set Target = Range("A1") 

    For Each FileName In arrFileList 
     Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True) 

     With WordDoc 
      tableNo = WordDoc.tables.Count 
      tableTot = WordDoc.tables.Count 
      If tableNo = 0 Then 
       MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table" 

      ElseIf tableNo > 1 Then 
       tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _ 
            "Enter the table to start from", "Import Word Table", "1") 
      End If 

      For tableStart = 1 To tableTot 
       With .tables(tableStart) 
        .Range.Copy 
        'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False 
        Target.Activate 
        ActiveSheet.Paste 

        Set Target = Target.Offset(.Rows.Count + 2, 0) 
       End With 
      Next tableStart 

      .Close False 
     End With 

    Next FileName 

    WordApp.Quit 

    Set WordDoc = Nothing 
    Set WordApp = Nothing 
End Sub 

Answer 2

您可以直接从Word拷贝整个表，然后使用Worksheet的PasteSpecial方法将其粘贴到Excel中。 Worksheet的PasteSpecial方法对于的PasteSpecial方法具有不同的选项。其中一个选项是Format，HTML设置将Word表格的格式应用于要粘贴到的Excel范围。

的Worksheet的PasteSpecial方法只使用活动单元格，所以你必须Select目标Range第一。似乎有点难看，但我没有看到替代方案。

下面是一个例子：

Option Explicit 

Sub Test() 
    Dim rngTarget As Range 

    Set rngTarget = ThisWorkbook.Worksheets("Sheet1").Range("A1") 

    WordTableToExcel "C:\Users\Robin\Desktop\foo1.docx", 1, rngTarget 

End Sub 

Sub WordTableToExcel(strWordFile As String, intWordTableIndex As Integer, rngTarget As Range) 

    Dim objWordApp As Object 
    Dim objWordTable As Object 

    On Error GoTo CleanUp 

    'get table from word document 
    Set objWordApp = GetObject(strWordFile) 
    Set objWordTable = objWordApp.Tables(intWordTableIndex) 
    objWordTable.Range.Copy 

    'paste table to sheet 
    rngTarget.Select 
    rngTarget.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False 

CleanUp: 
    'clean up word references 
    Set objWordTable = Nothing 
    Set objWordApp = Nothing 

End Sub 

关于你如何应用到多个文件的问题 - 你可以只保留调用这个可重用Sub每个Word文档，并遍历表按照该文件中循环你在你现有的代码中。