Thanks Paul, much appreciated. Works great.
I never realized this but the first page of each report is actually a Table. I added more code (found another one of your posts on a different website) to deal with this table and it is working great so far. Where I am having a particular problem is with the GetFolder Function. I would like this Function to deal with a parent folder that has multiple child folders. I would like it to cycle though each of the child folders. For example:
Parent folder
- Child folder 1
- Child folder 2
- Child folder 3
- Child folder ....
Where the word docs would be in the Child folders. If this should be posted as a new thread, please let me know.
Here's the code I have so far
Sub GetTextBoxData()'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdShp As Word.Shape, wdTbl As Word.Table
Dim strFolder As String, strFile As String, wkbk As Workbook, wksht As Worksheet, r As Long, t As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set wkbk = ActiveWorkbook
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False) 'ReadOnly=True if document is opened by someone else and to prevent any changes
Set wksht = wkbk.Sheets.Add
wksht.Name = Left(Split(strFile, ".doc")(0), 31) 'Excel will not allow sheet names to be >31 characters
With wdDoc
For Each wdTbl In .Tables
Select Case 1
Case 1
With wdTbl.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^13^l]"
.Replacement.Text = "¶"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
r = wksht.Cells(wksht.Rows.count, 1).End(xlUp).row
If r > 1 Then r = r + 2
wdTbl.Range.Copy
wksht.Paste Destination:=wksht.Range("A" & r)
Exit For
End Select
Next
For Each wdShp In .Shapes
With wdShp
If .Type = msoTextBox Then
With .TextFrame.TextRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^13^l]"
.Replacement.Text = "¶"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
r = wksht.Cells(wksht.Rows.count, 1).End(xlUp).row
r = r + 1
wksht.Range("A" & r).Value = .TextFrame.TextRange.Text
End If
End With
Next
wksht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set wksht = Nothing: Set wkbk = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Cheers,
Mac