複数のWord文書を開く

Question

初心者のために、私はVBAの経験が限られています。私はWordテーブルのテーブル（またはテーブル）からデータを取り出すExcelマクロを持っています。私の問題は、私が何千ものWord文書のようなものを持っていることです。そのため、ユーザーが選択したフォルダ内のすべてのWord文書のデータをコピーするソリューションが役立ちます。

は、ここに私の現在のコードです：

Sub ImportWordTables() 

'Imports cells from Word document Tables in multiple documents 

    Dim wdDoc   As Object 
    Dim TableNo  As Integer 'number of tables in Word doc 
    Dim iTable  As Integer 'table number index 
    Dim iRow   As Long  'row index in Excel 
    Dim iCol   As Integer 'column index in Excel 
    Dim ix As Long 
    ix = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count 
LastRow = ix 

    wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", MultiSelect = True, _ 
     "Browse for files 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 = 1 
     If TableNo = 0 Then 
     MsgBox "This document contains no tables", _ 
       vbExclamation, "Import Word Table" 

     End If 

     For iTable = 1 To TableNo 
     With .tables(iTable) 
      'copy cell contents from Word table cells to Excel cells in column A and B 
      Cells(ix + 1, "A") = WorksheetFunction.Clean(.Cell(1, 2)) 
      Cells(ix + 1, "B") = WorksheetFunction.Clean(.Cell(2, 2)) 
      Cells(ix + 1, "C") = WorksheetFunction.Clean(.Cell(3, 2)) 
      Cells(ix + 1, "D") = WorksheetFunction.Clean(.Cell(4, 2)) 
      Cells(ix + 1, "E") = WorksheetFunction.Clean(.Cell(5, 2)) 
      Cells(ix + 1, "F") = WorksheetFunction.Clean(.Cell(6, 2)) 
      Cells(ix + 1, "G") = WorksheetFunction.Clean(.Cell(6, 3)) 
      Cells(ix + 1, "H") = WorksheetFunction.Clean(.Cell(7, 2)) 
      Cells(ix + 1, "I") = WorksheetFunction.Clean(.Cell(8, 2)) 
      Cells(ix + 1, "J") = WorksheetFunction.Clean(.Cell(9, 2)) 
      Cells(ix + 1, "K") = WorksheetFunction.Clean(.Cell(10, 2)) 
Cells(ix + 1, "L") = WorksheetFunction.Clean(.Cell(13, 2)) 
     End With 
     Next iTable 
    End With 


    Set wdDoc = Nothing 
     End Sub 

私はループを作成する必要があることを知っているが、私は仕事に同様の質問で見つかったループの例のいずれかを変更することができませんでした。

Answer 1

Excelを使ってテーブルからデータを収集することはほとんど考えられませんでしたが、私はこれを面白い方法で見つけました。ここでいくつかのコードを使って尋ねている。私はあなたが求めていたものを超えて、確かにそれを調査したいと思うかもしれないことをここにいくつか挙げましたが、私が達成しようとしていることを理解できるようにコードにコメントしようとしました。

また、 。 。 Office Automationに関する重要なメモOfficeアプリケーションはCOM仕様（少なくとも以前のもの、新しいバージョンについてはわからない）に基づいているため、オブジェクトの作成と破棄の方法については本当に注意する必要があります。 COMは、別のオブジェクトへの参照を保持しているオブジェクトがある場合、その他のオブジェクトを破棄することはできないというルールを適用します。これは、ほとんどのオブジェクトがさまざまな方向で互いに参照を保持するため、Office Automationに深刻な影響を与えます。たとえばExcelの場合。 Excelアプリケーションはワークブックへの参照を保持するだけでなく、ワークブックはワークシートへの参照を保持します。ワークシートには、ワークブックへの参照（その親プロパティを介して）とそれ以降の行が表示されます。したがって、Excelのインスタンスを作成してからワークブックへの参照を取得し、そのワークブック内のワークシートへの参照を取得した場合、そのワークブックオブジェクトを一日中破棄することができます。それへの参照を保持しています。同じことがExcelアプリケーションオブジェクトについても当てはまります。 Officeのオブジェクトへの参照を作成するときは、作成した逆の順序でオブジェクトを破棄することが常にベストプラクティスです。作成：Excel =>ワークブック=>ワークシート。 Destroy：Set Worksheet = Nothing => Workbook.Close、Set Workbook = Nothing => Excel.Quit、Set Excel = Nothing。

この一般的な規則に従わないと、プロセスが数回実行され、オブジェクトが実行されていないため、3つまたは4つのインスタンスのExcel（多くのメモリを詰まらせる）がマシン上で開いたままになるため、破壊された。

大丈夫です。 。 。私は今、私の石鹸ボックスを降りてきます。ここに私が作成したコードがあります。楽しい！

Option Explicit 

Public Sub LoadWordData() 
    On Error GoTo Err_LoadWordData 

    Dim procName As String 
    Dim oWks As Excel.Worksheet 
    Dim oWord As Word.Application 
    Dim oWordDoc As Word.Document '* Requires a reference to the Microsoft Word #.# Object Library 
    Dim oTbl As Word.Table 
    Dim oFSO As FileSystemObject '* Requires a reference to the Microsoft Scripting Runtime library 
    Dim oFiles As Files 
    Dim oFile As File 
    Dim oAnchor As Excel.Range 

    Dim strPath As String 
    Dim fReadOnly As Boolean 
    Dim iTableNum As Integer 
    Dim iRowOffset As Long 

    procName = "basGeneral::LoadWordData()" 

    fReadOnly = True 
    Set oWks = GetWordDataWks() 

    If Not oWks Is Nothing Then 
     iRowOffset = oWks.UsedRange.Row + oWks.UsedRange.Rows.Count - 1 
     strPath = GetPath() 

     If strPath <> "" Then 
      Set oWord = New Word.Application 
      Set oFSO = New FileSystemObject 
      Set oAnchor = oWks.Range("$A$1") 


      Set oFiles = oFSO.GetFolder(strPath).Files 

      For Each oFile In oFiles 
       If IsWordDoc(oFile.Type) Then 
        iTableNum = 0 
        Set oWordDoc = oWord.Documents.Open(strPath & oFile.Name, , fReadOnly) 

        For Each oTbl In oWordDoc.Tables 
         iTableNum = iTableNum + 1 

         oAnchor.Offset(iRowOffset, 0).Formula = oFile.Name 
         oAnchor.Offset(iRowOffset, 1).Formula = iTableNum 
         oAnchor.Offset(iRowOffset, 2).Formula = GetCellValue(oTbl, 1) 
         oAnchor.Offset(iRowOffset, 3).Formula = GetCellValue(oTbl, 2) 
         oAnchor.Offset(iRowOffset, 4).Formula = GetCellValue(oTbl, 3) 
         oAnchor.Offset(iRowOffset, 5).Formula = GetCellValue(oTbl, 4) 
         oAnchor.Offset(iRowOffset, 6).Formula = GetCellValue(oTbl, 5) 
         oAnchor.Offset(iRowOffset, 7).Formula = GetCellValue(oTbl, 6) 

         iRowOffset = iRowOffset + 1 
        Next oTbl 

        oWordDoc.Close 
        Set oWordDoc = Nothing 
       End If 
      Next oFile 
     End If 
    Else 
     MsgBox "The Worksheet to store the data could not be found. All actions have been cancelled.", vbExclamation, "Word Table Data Worksheet Missing" 
    End If 

Exit_LoadWordData: 
    On Error Resume Next 
    '* Make sure you cleans things up in the proper order 
    '* This is EXTREAMLY IMPORTANT! We close and destroy the 
    '* document here again in case something errored and we 
    '* left one hanging out there. This can leave multiple 
    '* instances of Word open chewing up A LOT of memory. 
    Set oTbl = Nothing 
    oWordDoc.Close 
    Set oWordDoc = Nothing 
    oWord.Quit 
    Set oWord = Nothing 
    Set oFSO = Nothing 
    Set oFiles = Nothing 
    Set oFile = Nothing 
    Set oAnchor = Nothing 
    MsgBox "The processing has been completed.", vbInformation, "Processing Complete" 
    Exit Sub 

Err_LoadWordData: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error in Proc: " & procName 
    Resume Exit_LoadWordData 

End Sub 

Private Function GetPath() As String 
    On Error GoTo Err_GetPath 

    Dim procName As String 
    Dim retVal As String 

    procName = "basGeneral::GetPath()" 

    '* This is where you can use the FileDialogs to pick a folder 
    '* I'll leave that up to you, I'll just pick the folder that 
    '* my workbook is sitting in. 
    '* 
    retVal = ThisWorkbook.Path & "\" 

Exit_GetPath: 
    On Error Resume Next 
    GetPath = retVal 
    Exit Function 

Err_GetPath: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error in Proc: " & procName 
    Resume Exit_GetPath 

End Function 

Private Function IsWordDoc(ByVal pFileType As String) As Boolean 
    On Error GoTo Err_IsWordDoc 

    Dim procName As String 
    Dim retVal As Boolean 
    Dim iStart As Integer 

    procName = "basGeneral::IsWordDoc()" 

    '* This could obviously have been done in may different ways 
    '* including in a single statement. 
    '* I did it this way so it would be obvious what is happening 
    '* 
    '* You could examine the file extension as well but you'd have 
    '* to strip it off yourself because the FileSystemObject doesn't 
    '* have that property 
    '* Plus there are moree than one extension for Word documents 
    '* these days so you'd have to account for all of them. 
    '* This was, simply, the easiest and most thorough in my opinion 
    '* 
    retVal = False 

    iStart = InStr(1, pFileType, "Microsoft") 
    If iStart > 0 Then 
     iStart = InStr(iStart, pFileType, "Word") 
     If iStart > 0 Then 
      iStart = InStr(iStart, pFileType, "Document") 
      If iStart > 0 Then 
       retVal = True 
      End If 
     End If 
    End If 

Exit_IsWordDoc: 
    On Error Resume Next 
    IsWordDoc = retVal 
    Exit Function 

Err_IsWordDoc: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error in Proc: " & procName 
    Resume Exit_IsWordDoc 

End Function 

Private Function GetWordDataWks() As Excel.Worksheet 
    On Error GoTo Err_GetWordDataWks 

    Dim procName As String 
    Dim retVal As Excel.Worksheet 
    Dim wks As Worksheet 

    procName = "basGeneral::GetWordDataWks()" 

    Set retVal = Nothing 

    '* Here's the deal . . . I really try hard not to EVER use the 
    '* ActiveWorkbook and ActiveWorksheet objects because you can never 
    '* be absolutely certain what you will get. I prefer to explicitly 
    '* go after the objects I need like I did here. 
    '* 
    '* I also never try to get a reference to a Worksheet using it's Tab Name. 
    '* Users can easily change the Tab Name and that can really mess up all 
    '* your hard work. I always use the CodeName which you can find (and set) 
    '* in the VBA IDE in the Properties window for the Worksheet. 
    '* 
    For Each wks In ThisWorkbook.Worksheets 
     If wks.CodeName = "wksWordData" Then 
      Set retVal = wks 
      Exit For 
     End If 
    Next wks 

Exit_GetWordDataWks: 
    On Error Resume Next 
    Set GetWordDataWks = retVal 
    Exit Function 

Err_GetWordDataWks: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error in Proc: " & procName 
    Resume Exit_GetWordDataWks 

End Function 

Private Function GetCellValue(ByRef pTable As Word.Table, ByVal pRow As Long) As Variant 
    On Error GoTo Err_GetCellValue 

    Dim procName As String 
    Dim retVal As Variant 
    Dim strValue As String 

    procName = "basGeneral::GetCellValue()" 

    strValue = WorksheetFunction.Clean(pTable.cell(pRow, 2).Range.Text) 

    If IsNumeric(strValue) Then 
     retVal = Val(strValue) 
    Else 
     retVal = strValue 
    End If 

Exit_GetCellValue: 
    On Error Resume Next 
    GetCellValue = retVal 
    Exit Function 

Err_GetCellValue: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Error in Proc: " & procName 
    Resume Exit_GetCellValue 

End Function