打開多個Word文檔

Question

僅供初學者使用，我的VBA體驗有限，而且我主要修改我在網上發佈的內容。我有一個Excel宏，可以從Word表格中的表格（或多個表格）中獲取數據。我的問題是，我擁有一千個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從「數千」Word文檔中的表中收集數據，但我確實發現這是一個有趣的練習，所以這裏是一些代碼，我把它們放在一起做什麼（我認爲）你在問。我已經在這裏列出了一些你可能想要調查的東西，無可否認，它超出了你所要求的範圍，但我試圖評論這些代碼，以便你能夠弄清楚我正在努力完成什麼。

另外。 。 。關於Office自動化的一個非常重要的注意由於Office應用程序基於COM規範（至少是早期版本，不確定較新的版本），您必須非常小心地瞭解如何創建和銷燬對象。 COM強制執行一條規則，規定如果存在一個持有對另一個對象的引用的對象，則該另一個對象不能被銷燬。這對Office自動化有嚴重影響，因爲大多數對象在各種方向上都保持對方的引用。例如在Excel中; Excel應用程序不僅保存對工作簿的引用，而且工作簿保存對工作表的引用。工作表包含對工作簿的引用（通過它的父屬性），等等。因此，如果您創建一個Excel實例，然後獲取對工作簿的引用，然後在該工作簿中獲取對工作表的引用，則可以嘗試整天摧毀該工作簿對象，並且它不會因爲工作表正在提及它。對於Excel應用程序對象也是如此。在Office中創建對象的引用時，按照與創建對象相反的順序銷燬對象始終是最佳做法。創建：Excel =>工作簿=>工作表。銷燬：Set Worksheet = Nothing => Workbook.Close，Set Workbook = Nothing => Excel.Quit，Set Excel = Nothing。

不遵循這個通用規則導致無數機器崩潰，因爲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