Search sheet and list results in a doc

[gibbo1715]

I have the code below to change the colour of words when found in a word document (When run from within MS Word)

Selection.Find.ClearFormatting
 Selection.Find.Replacement.ClearFormatting
With Selection.Find
 .Text = "test"
 .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
 Selection.Find.Execute Replace:=wdReplaceAll

Can anyone help with the following

I need to search an excel spreadsheet (From within excel), if the search string is found copy the row (or Columns A:E of that row anyway) into a word document and then move on to search the next row and so on.... When the search is complete run the above code on the created word document.

Many thanks

[Jacob Hilderbrand]

This is how you can setup the search loop.

Option Explicit
 
Sub Macro1()
Dim Cel As Range
 Dim WS As Worksheet
 Dim FirstAddress As String
Set WS = ThisWorkbook.Sheets("Sheet1")
With WS.Cells
       Set Cel = .Find(What:="Some Text", LookIn:=xlValues, _
       LookAt:=xlWhole, MatchCase:=True)
       If Not Cel Is Nothing Then
       FirstAddress = Cel.Address
       Do
            Cel.Interior.ColorIndex = 5
            Set Cel = .FindNext(Cel)
        Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
     End If
  End With
End Sub

Check Here for how to copy from Excel to Word.

[gibbo1715]

Thanks Jake

Does do what i want but need to leave the original in the excel workbook with the colours unchanged if you can help with that

I would if possible prefer to run my word macro on the doc when it has been created running the macro from excel if thats possible

As most things i ask of you you seem to be able to work out I will thank you in advance

Cheers

Paul

[Jacob Hilderbrand]

Cel.Interior.ColorIndex = 5

That line was just there to show what cells were matching the criteria as an example. You can just remove that line completely.

You will need to set some variable to the Word Application. Let's say it is called AppWrd. Then you can run your code as follows.

AppWrd.Selection.Find.ClearFormatting
 AppWrd.Selection.Find.Replacement.ClearFormatting
With AppWrd.Selection.Find
     .Text = "test"
     .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
 AppWrd.Selection.Find.Execute Replace:=wdReplaceAll

Also note that you will need to set a reference to the Microsoft Word Object Library from the VBE (Tools | References).

[gibbo1715]

This does the copy paste and highlights the word as I require so thanks once again

Next question though is I only want to copy the rows that contain the data I am searching for, and there may be several rows containing this data. I can think of a way of doing this by copying the data to a temp sheet first before exporting it but im sure there must be an easier way

Any Ideas?

Option Explicit
  
 Sub Macro1()
Dim Cel             As Range
     Dim WS              As Worksheet
     Dim FirstAddress    As String
Set WS = ThisWorkbook.Sheets("Sheet1")
     With WS.Cells
         Set Cel = .Find(What:="Test", LookIn:=xlValues, _
         LookAt:=xlPart, MatchCase:=True)
         If Not Cel Is Nothing Then
             FirstAddress = Cel.Address
             Do
                'Cel.Interior.ColorIndex = 5
                 Set Cel = .FindNext(Cel)
             Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
         End If
     End With
      Call PasteToWord
 End Sub
 
Sub PasteToWord()
Dim AppWord         As Word.Application
Set AppWord = CreateObject("Word.Application")
AppWord.Visible = True
      '  Change the range to suit your needs. See the How to Use for this code
     Sheets("Sheet1").Range("A1:A40").Copy
     AppWord.Documents.Add
     AppWord.Selection.Paste
     AppWord.Selection.Find.ClearFormatting
     AppWord.Selection.Find.Replacement.ClearFormatting
With AppWord.Selection.Find
     .Text = "test"
     .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
End Sub

Thanks Again

[Jacob Hilderbrand]

What you need to do is copy and paste within the loop.

Try this.

Option Explicit
  
 Sub Macro1()
Dim Cel             As Range
     Dim WS              As Worksheet
     Dim FirstAddress    As String
     Dim AppWord         As Word.Application
Set AppWord = CreateObject("Word.Application")
     AppWord.Documents.Add
     Set WS = ThisWorkbook.Sheets("Sheet1")
     With WS.Cells
         Set Cel = .Find(What:="Test", LookIn:=xlValues, _
         LookAt:=xlPart, MatchCase:=True)
         If Not Cel Is Nothing Then
             FirstAddress = Cel.Address
             Do
                 WS.Range("A" & Cel.Row & ":E" & Cel.Row).Copy
                 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 = "test"
         .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
End Sub

[gibbo1715]

Thanks again Jake

Leant something new and that is always good

[Jacob Hilderbrand]

You're Welcome

Take Care