对于初学者来说，我的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
我知道我需要创建一个循环，但我无法改变在类似问题中找到的任何循环示例。
答案 0 :(得分：2)
虽然我很可能不会考虑使用Excel从“数千”Word文档中的表中收集数据，但我确实发现这是一个有趣的练习，所以这里是一些代码，我把它们放在一起做（我认为）你是问。我在这里列出了一些你可能想要调查的东西，不可否认，它超出了你所要求的范围，但我试图评论代码，以便你能弄清楚我想要完成的事情。
另外。 。 。关于Office Automation的一个非常重要的注意事项由于Office应用程序基于COM规范（至少是早期版本，不确定新版本），因此在创建和销毁对象时必须非常小心。 COM强制执行一条规则，该规则说明如果有一个对象持有对另一个对象的引用，则该另一个对象不能被销毁。这对Office自动化具有严重影响，因为大多数对象在各种方向上都相互引用。例如在Excel中; Excel应用程序不仅保存对工作簿的引用，而且工作簿还包含对工作表的引用。工作表包含对工作簿的引用（通过它的父属性），依此类推。因此，如果您创建一个Excel实例，然后获取对工作簿的引用，然后获取该工作簿中的工作表的引用，您可以尝试整天销毁该工作簿对象，它将永远不会消失，因为工作表正在引用它。对于Excel应用程序对象也是如此。在Office中创建对象的引用时，最好按照与创建对象相反的顺序销毁对象。创建：Excel =＆gt;工作簿=＆gt;工作表。销毁：设置工作表= Nothing =＆gt; Workbook.Close，Set Workbook = Nothing =＆gt; Excel.Quit，设置Excel =无。
不按照这个一般规则导致无数机器崩溃，因为三个或四个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