在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文檔，並遍歷表按照該文件中循環你在你現有的代碼中。