Hi Airborne,
I've been playing around with an Index solution and come up with the following
This code has to be inserted in each of your workbooks
[VBA] Option Explicit
Option Base 1

Sub GetBoxText()
Dim MyWS As Worksheet

Dim BoxText()
Dim i!, j!

'If no Data sheet then exit sub
Sheets("Data").Select
If Err <> 0 Then Exit Sub

'Create FindWord sheet if it does not exist
On Error Resume Next
Sheets("FindWord").Select
If Err <> 0 Then
'error occured so clear it
Err.Clear
Sheets.Add.Name = "MyIndex"
Sheets("MyIndex").Move After:=Sheets(Sheets.Count)
End If

Set MyWS = ActiveWorkbook.Sheets("Data")

ReDim BoxText(MyWS.Shapes.Count)
For i = 1 To MyWS.Shapes.Count
If Left(MyWS.Shapes(i).Name, 5) = "Text " Then
j = j + 1
BoxText(j) = MyWS.Shapes(i).TextFrame.Characters.Text
End If
Next i
ReDim Preserve BoxText(j)
Sheets("MyIndex").UsedRange.ClearContents
For i = 1 To j
Sheets("MyIndex").Cells(i, 1) = BoxText(i)
Next
End Sub

[/VBA]
and also the following which calls the code, to keep things up to date
[VBA]
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
GetBoxText
End Sub

[/VBA]

You can then run a slightly modified version of DRJs FinalAll programme as attached.

I'm sure with your experience now, you can iron out any version bugs!

MD