打开多个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