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 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=81) 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 :beerchug:

Take Care