Have a look at the code below, DRJ Helped me with a slightly similar option, will not do exactly what you want but should get you on the right path

Also you need to set a reference to word or it wont work

Private Sub CommandButton1_Click()
Dim cel             As Range
Dim ws              As Worksheet
Dim FirstAddress    As String
Dim AppWord         As Word.Application
Dim Word            As String
Dim Prompt          As String
Dim Search          As String
Dim Doc             As Document
Prompt = "What do you want to search for?"
Title = "Search Criteria"
Search = InputBox(Prompt, Title)
If Search = "" Then
    MsgBox "Nothing Selected"
exit sub
End If
Application.Cursor = xlWait
Set AppWord = CreateObject("Word.Application")
Set Doc = AppWord.Documents.Add '
Doc.PageSetup.Orientation = wdOrientLandscape
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws.Cells
    Set cel = .Find(What:=Search, LookIn:=xlValues, _
    LookAt:=xlPart, MatchCase:=False)
    If Not cel Is Nothing Then
        FirstAddress = cel.Address
        Do
            ws.Range("A" & cel.Row & ":G" & cel.Row).Copy' select what you want to 'copy, im copying the row from A: G
            AppWord.Selection.Paste
            Set cel = .FindNext(cel)
        Loop While Not cel Is Nothing And cel.Address <> FirstAddress
    End If
End With
AppWord.Selection.Find.ClearFormatting
AppWord.Selection.Find.Replacement.ClearFormatting
With AppWord.Selection.Find
    .Text = Search
    .Replacement.Font.name = "Arial Black"
    .Replacement.Font.Color = wdColorRed
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
AppWord.Selection.Find.Execute Replace:=wdReplaceAll
AppWord.Visible = True
Application.Cursor = xlDefault
End Sub