Excel VBAでのWordテーブルの書式設定

Question

別の説明から、WordからExcelにテーブルをインポートするこのマクロが見つかりました。

素晴らしいですが、Wordテーブルの書式設定をどのように保つことができますか？

私はいくつかの方法を試しましたが、うまく機能しません。一度に1つではなく、一度に多くのファイルを処理する方法もありますか？

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の方法は、Rangeの方法とは異なる選択肢を有する。これらのオプションの1つはFormatで、HTML設定では、貼り付け先のExcel範囲にWord表の形式が適用されます。

Worksheetの方法はアクティブセルを使用するだけなので、先に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各単語のための文書を呼び出しておくと繰り返すことができますあなたの既存のコードにあるループ。