Сохранение форматирования таблицы Word в Excel VBA

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

Вы можете просто скопировать всю таблицу из Слова, а затем вставьте его в Excel, используя PasteSpecial метод Worksheet. Метод PasteSpecialWorksheet имеет различные варианты для метода PasteSpecial для Range. Один из этих параметров - Format, а параметр HTML применяет формат таблицы Word к приложенному диапазону Excel.

Метод PasteSpecialWorksheet использует только активную ячейку, поэтому сначала необходимо установить 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 для каждого слова документа и перебрать таблицы, приведенные в этом документе согласно в вашем существующем коде.