Хотя я, скорее всего, не стал бы использовать Excel для сбора данных из таблиц в «тысячи» документов Word, я нашел это интересным упражнением, поэтому вот код, который я собрал, чтобы сделать то, чем (я думаю) вы являетесьспрашивая.Я включил здесь несколько вещей, которые вы, возможно, захотите исследовать, которые, по общему признанию, выходят далеко за рамки того, о чем вы просили, но я попытался прокомментировать код, чтобы вы могли понять, чего я пытаюсь достичь.
Также.,,Одно действительно важное замечание об автоматизации Office.Так как приложения Office основаны на спецификации COM (по крайней мере, более ранние, не уверенные в новых версиях), вы должны быть ДЕЙСТВИТЕЛЬНО осторожны в том, как вы создаете и уничтожаете объекты.COM применяет правило, которое говорит, что если существует объект, который содержит ссылку на другой объект, то этот другой объект не может быть уничтожен.Это имеет серьезные последствия в автоматизации Office, поскольку большинство объектов содержат ссылки друг на друга во всех направлениях.Например, в Excel;Приложение Excel не только содержит ссылку на рабочую книгу, но и рабочую книгу содержит ссылку на рабочую таблицу.Рабочий лист содержит ссылку на рабочую книгу (через свойство Parent) и так далее в строке.Следовательно, если вы создаете экземпляр Excel, а затем получаете ссылку на рабочую книгу, а затем получаете ссылку на рабочую таблицу в этой рабочей книге, вы можете попытаться уничтожить этот объект рабочей книги в течение всего дня, и он никогда не исчезнет, поскольку рабочая таблицадержит ссылку на это.То же самое относится и к объекту приложения Excel.При создании ссылок на объекты в Office всегда рекомендуется уничтожать объекты в обратном порядке, в котором они были созданы.Создать: Excel => Рабочая книга => Рабочая таблица.Уничтожить: установить рабочий лист = Nothing => Workbook.Close, установить Workbook = Nothing => Excel.Quit, установить 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