打开多个Word文档

对于初学者来说，我的VBA经验有限，而且我主要修改我在网上看到的东西。 我有一个Excelmacros，可以从Word表格中的一个或多个表中获取数据。 我的问题是，我有一千个Word文档，所以我想帮助一个解决scheme，从用户选定的文件夹中的所有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 

我知道我需要创build一个循环，但我无法改变我在类似问题中find的任何循环示例。

Answer 1

虽然我很可能不会考虑使用Excel从“数千”Word文档中的表中收集数据，但是我确实发现这是一个有趣的练习，所以这里是一些代码，我把它们放在一起做你想问什么（我想）。 我已经在这里列出了一些你可能想要调查的东西，不可否认的是，要超出你所要求的范围，但是我试图评论这些代码，以便你能够弄清楚我正在努力完成什么。

还有 。 。 关于Office自动化的一个非常重要的注意 由于Office应用程序是基于COM规范（至less是以前的，不知道较新的版本），你必须非常小心，如何创build和销毁对象。 COM强制执行规则，如果有一个对象持有对另一个对象的引用，则该对象不能被销毁。 这在办公自动化中有严重的影响，因为大多数对象在各种方向上都相互引用。 例如在Excel中; Excel应用程序不仅保存对工作簿的引用，而且工作簿也保存对工作表的引用。 工作表包含对工作簿的引用（通过它的父属性），等等。 因此，如果您创build一个Excel实例，然后获取对工作簿的引用，然后获取对该工作簿中的工作表的引用，则可以尝试整天摧毁该工作簿对象，并且不会因为工作表提到它。 对于Excel应用程序对象也是如此。 在Office中创build对象的引用时，按照与创build对象相反的顺序销毁对象始终是最佳做法。 创build：Excel =>工作簿=>工作表。 销毁：设置Worksheet = Nothing => Workbook.Close，Set Workbook = Nothing => Excel.Quit，Set Excel = Nothing。

没有遵循这个通用规则，导致无数的机器崩溃，因为三个或四个Excel实例（咀嚼了大量的内存）在一台机器上保持打开状态，因为该进程已经运行了好几次，对象还没有被销毁。

好的 。 。 。 我现在要脱掉我的肥皂盒。 这是我创build的代码。 请享用！

 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