Automate copying text from tables on multiple identical docs

[Dez93]

Hi all. I've got 300 grant application forms from which i'd like to extract
the names (1st & surname, 1+ times per sheet since some have more
co-applicants than others) and also applicants current grants (another text
box later on, one per applicant).
Forms are simple tables, so i was wondering if there's a way to write a
macro saying: "copy both the two cells right of any one which says 'name',
AND paste it on this other spreadsheet, THEN copy the cell right of any one
saying 'current grants' AND paste it into that same spreadsheet as before"

I can imagine that's possible for forms which might have name-labelled
formfields which can be thus referenced, but for plain tables?
Anyone else got any fiendishly smart ways i might get around this? Basically
i just want to strip out all the names and pour them onto a spreadsheet to
make sure nobody gets asked to review a competitor.

If anyone can genius-up an answer, i'll love ya!
Cheers

Si

 

[Shauna Kelly]

Hi Dez93

It looks like you've got three bits of work to do here.

Step 1 is to work out how to get the text you need. And here's some code to
show how you might do that.

Step 2 is to work out how to put it into a spreadsheet. There's info on
automating Excel from Word here:
Control Excel from Word
http://www.word.mvps.org/FAQs/InterDev/ControlXLFromWord.htm

Step 3 is to work out how to cycle through all your documents to capture the
information. There's an example of how to cycle through all the documents in
a folder here:
Find & ReplaceAll on a batch of documents in the same folder
http://www.word.mvps.org/FAQs/MacrosVBA/BatchFR.htm


Option Explicit

Sub GetNames()

'Assumes 3 cells: one says "Name", the next one holds
'the first name, and the next next one holds the last name.

'The string you're searching for
Const sName As String = "Name"

Dim cellFound As Word.Cell
Dim sFirstName As String
Dim sLastName As String
Dim rngDoc As Word.Range
Dim rngFirstName As Word.Range
Dim rngLastName As Word.Range

On Error GoTo ErrorHandler:

Set rngDoc = ActiveDocument.Range
With rngDoc.Find
.ClearAllFuzzyOptions
.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Text = sName 'what to look for
.Format = False

Do While .Execute

'If we found our text...
If rngDoc.Information(wdWithInTable) Then
'... and it's in a table, then
'get a reference to the cell
Set cellFound = rngDoc.Cells(1)

'Get the range of the first name
Set rngFirstName = cellFound.Next.Range

'Strip the end of cell markers
rngFirstName.MoveEndWhile _
Cset:=Chr(13) & Chr(7), _
Count:=wdBackward

'Store the first name
sFirstName = rngFirstName.Text


'Get the range of the last name
Set rngLastName = cellFound.Next.Next.Range

'Strip the end of cell markers
rngLastName.MoveEndWhile _
Cset:=Chr(13) & Chr(7), _
Count:=wdBackward

'Store the last name
sLastName = rngLastName.Text

'You're ready to use the names
MsgBox sFirstName & " " & sLastName

'Get ready to find the next name
rngDoc.Collapse wdCollapseEnd
End If
Loop 'Go look for another name
End With

EndSub:

'Clean up and go home
Set cellFound = Nothing
Set rngDoc = Nothing
Set rngFirstName = Nothing
Set rngLastName = Nothing

Exit Sub

ErrorHandler:
MsgBox "Sorry, could not get the names"
Resume EndSub:

End Sub


Hope this helps.

Shauna Kelly. Microsoft MVP.
http://www.shaunakelly.com/word