Hello,

I?m back on this project.
It works as required thanks to Tony and others. Although I do have a problem if I copy the data to a sheet other than sheet 1. If I change the code to copy to another sheet only a portion of the data is copied. It is the same result if I name the sheets and use the sheet name in the code. Ultimately I will be searching for several words and coping to a different sheet for each word so I would like the ability to select which sheet to copy the data to.
Your continued help is greatly much appreciated.

My current code is below. If it is possible in this forum I can attach a sample document if required.

Regards,
Ron

[VBA]Sub FindWordCopySentence()

Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim bRange As Range
Dim intRowCount As Integer
Dim strFileNameAndPath As String
Dim lngDisplayVal As Long
Dim PathAndFileName As String
On Error Resume Next

'open dialog box for user to select file
'and put path and file name in varable
With Application.Dialogs(wdDialogFileOpen)
lngDisplayVal = .Display
strFileNameAndPath = WordBasic.FileNameInfo$(.Name, 1)
End With
If lngDisplayVal <> -1 Then
MsgBox prompt:="Procedure canceled. Must select a file."
Exit Sub
End If

intRowCount = 3

Set aRange = ActiveDocument.Range
Set bRange = ActiveDocument.Range

With aRange.Find
Do
.Text = "shall" ' search word
.Execute
If .Found Then
aRange.Expand unit:=wdSentence
aRange.Copy

If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Set objSheet = appExcel.Workbooks.Open(strFileNameAndPath).Sheets("Sheet2")
End If

objSheet.Cells(intRowCount, 3).Select
objSheet.Paste
bRange.End = aRange.End
bRange.Collapse wdCollapseEnd

bRange.Find.ClearFormatting
bRange.Find.Font.Bold = True
With bRange.Find
.Text = ""
.Forward = False
.Wrap = wdFindStop
.Format = True
End With
bRange.Find.Execute

bRange.Copy

objSheet.Cells(intRowCount, 1).Select
objSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
intRowCount = intRowCount + 1

aRange.Collapse wdCollapseEnd
End If
Loop While .Found
End With
If Not objSheet Is Nothing Then
appExcel.Workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
End Sub[/VBA]