Dan:
The following macro will let you browse to a folder, iterate through all the
Word documents, read selected data into an array, and then write that array
into an Excel worksheet. This is an Excel macro, and needs to go into a
module in the workbook you want to update. With Excel open, press Alt+F11,
then from the Insert menu choose Module. Copy all the code below and paste
it into that module. While you're in the VBE, you must also set references
to the Microsoft Word and Microsoft Shell Controls And Automation libraries.
From the Tools menu, select References - scroll down to and check the boxes
next to Microsoft Word [version number] Object Library and Microsoft Shell
Controls And Automation.
To run the macro, from your worksheet press Alt+F8 and select UpdateFiles.
This macro assumes the following:
-- When you run it, you have the Excel workbook that will be updated open,
with the sheet to be updated on top.
-- All the Word files you want to read in the folder end with .doc
extension.
-- The data is in the first table in each document.
-- All the data you want to read is in the same row in adjacent column
cells.
-- The data is to be written into the first empty row in Column A.
-- When I tested this, I had three Word files, each with a 1-row, 6-column
table. This is set now for an array of six data positions, and will read up
to 100 files.
Any of these can be changed - some changes may take more adjusting than
others. If you need to run this from Word, that adjustment can also be
done.
Ed
PS -Watch out for line wrap, depending on your newsgroup reader. Some long
lines of code may break where they shouldn't, giving you errors. If you
paste this in and some lines show up in red, you may have line wrap errors.
You can also go to the Debug menu and select Compile VBA Project to check
for errors before running.
''******* Begin Code **********
Option Explicit
Option Base 1
Dim fName As String ' Folder holding Word files
Dim dName As String ' Word file with data
Dim objWkb As Workbook
Dim objWks As Worksheet
Dim arData(6, 100) As String
Dim strData As String
Dim cntFile As Long
Dim x As Long, y As Long
Dim LastRow As Long
Dim appWord As New Word.Application
Dim docWord As Word.Document
Dim rngWord As Word.Range
Dim tblWord As Word.Table
'
Sub UpdateFiles()
' Set Excel objects
Set objWkb = ActiveWorkbook
Set objWks = objWkb.ActiveSheet
' Find first empty row
LastRow = objWks.Range("A65536").End(xlUp).Row
cntFile = 0
' Get folder with Word files
fName = GetFolderName("Choose a folder")
If fName = "" Then Exit Sub
' Get Word data file
With Application.FileSearch
.LookIn = fName
.Filename = "*.doc"
y = .FoundFiles.Count
Do While .Execute
cntFile = cntFile + 1
If cntFile > y Then Exit Do
dName = .FoundFiles(cntFile)
On Error GoTo CleanUp
' Set Word objects
Set docWord = appWord.Documents.Open(dName)
Set tblWord = docWord.Tables(1)
' Read table into array
For x = 1 To 6 ' assumes six columns
Set rngWord = tblWord.cell(1, x).Range
arData(cntFile, x) = Left(rngWord.Text, Len(rngWord.Text) - 2)
Next x
docWord.Close
Loop
End With
' Write array data into worksheet
For y = 1 To cntFile - 1
For x = 1 To 6
objWks.Cells(LastRow, x) = arData(y, x)
Next x
LastRow = LastRow + 1
Next y
objWkb.Save
CleanUp:
Set docWord = Nothing
appWord.Quit
Set appWord = Nothing
On Error GoTo 0
End Sub
Function GetFolderName(sCaption As String) As String
'Needs a reference to (Tools > Reference)
'Microsoft Shell Controls And Automation
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oItems As Shell32.FolderItems
Dim Item As Shell32.FolderItem
On Error GoTo CleanUp
Set oShell = New Shell
Set oFolder = oShell.BrowseForFolder(0, sCaption, 0)
Set oItems = oFolder.Items
Set Item = oItems.Item
GetFolderName = Item.Path
CleanUp:
Set oShell = Nothing
Set oFolder = Nothing
Set oItems = Nothing
Set Item = Nothing
End Function
''******* End Code **********
