Excel / Word Search and replace help please...

[huangqi01]

I have set up some code to search and replace data in my word files based on excel columns. IT works ok... (although I get a small erroe at the end.. Anyway, what it does not do, is preserve the formatting in the excel spread sheet.

For example, I have colored text / italics in my excel spreadsheet, that just gets put into the word file with the formatting of the previous text (in word). Any help would be appreciated?

Here is my current code:

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim row As Integer
Dim tString As String, tRange As Word.Range
Dim findtext As Long, r As Long
Dim totalrows As Integer

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\replace\replace.doc")
Set wrdSelection = wrdApp.Selection

totalrows = ActiveSheet.UsedRange.Rows.Count

With wrdSelection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With


For row = 2 To totalrows Step 1

wrdSelection.Find.Text = ActiveSheet.Cells(row, 1).Value
wrdSelection.Find.Replacement.Text = ActiveSheet.Cells(row, 2).Value
wrdSelection.Find.Execute Replace:=wdReplaceAll

Next row

wrdDoc.Save

End Sub

 

[SkipVought]

Hi,

Something like this...

  For Row = 2 To totalrows Step 1
    With ActiveSheet
      wrdSelection.Find.Text = .Cells(Row, 1).Value
      wrdSelection.Find.Replacement.Text = .Cells(Row, 2).Value
      wrdSelection.Find.Text.Font.Bold = .Cells(Row, 2).Font.Bold
      wrdSelection.Find.Text.Font.Italic = .Cells(Row, 2).Font.Italic
      wrdSelection.Find.Text.Font.Color = .Cells(Row, 2).Font.Color
      wrdSelection.Find.Execute Replace:=wdReplaceAll
    End With
  Next Row

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[huangqi01]

Thanks for the reply. I like the idea, but cannot get it to work.

I received a runtime error 424 at:
wrdSelection.Find.Text.Font.Bold = .Cells(row,2).Font.Bold

Here is the full code:

Sub Replace()
' to test this code, paste it into an Excel module
' add a reference to the Word-library
' create a new folder named C:\Foldername or edit the filnames in the code
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim row As Integer
Dim tString As String, tRange As Word.Range
Dim findtext As Long, r As Long
Dim totalrows As Integer

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\replace\replace.doc")
Set wrdSelection = wrdApp.Selection

totalrows = ActiveSheet.UsedRange.Rows.Count

With wrdSelection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

For row = 2 To totalrows Step 1
With ActiveSheet
wrdSelection.Find.Text = .Cells(row, 1).Value
wrdSelection.Find.Replacement.Text = .Cells(row, 2).Value
wrdSelection.Find.Text.Font.Bold = .Cells(row, 2).Font.Bold
wrdSelection.Find.Text.Font.Italic = .Cells(row, 2).Font.Italic
wrdSelection.Find.Text.Font.Color = .Cells(row, 2).Font.Color
wrdSelection.Find.Execute Replace:=wdReplaceAll
End With
Next row
wrdDoc.Save

End Sub


-----------------
My second attempt gave me the same error.

Sub Replace()
' to test this code, paste it into an Excel module
' add a reference to the Word-library
' create a new folder named C:\Foldername or edit the filnames in the code
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim row As Integer
Dim tString As String, tRange As Word.Range
Dim findtext As Long, r As Long
Dim totalrows As Integer

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\replace\replace.doc")
Set wrdSelection = wrdApp.Selection

totalrows = ActiveSheet.UsedRange.Rows.Count

With wrdSelection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

For row = 2 To totalrows Step 1

wrdSelection.Find.Text = ActiveSheet.Cells(row, 1).Value
wrdSelection.Find.Replacement.Text = ActiveSheet.Cells(row, 2).Value
wrdSelection.Find.Text.Font.Bold = ActiveSheet.Cells(row, 2).Font.Bold
wrdSelection.Find.Text.Font.Italic = ActiveSheet.Cells(row, 2).Font.Italic
wrdSelection.Find.Text.Font.Color = ActiveSheet.Cells(row, 2).Font.Color
wrdSelection.Find.Execute Replace:=wdReplaceAll
Next row

wrdDoc.Save

Any help would be great!

-HuangQi

End Sub

 

[huangqi01]

One more issue... If anyone knows how to include the footnotes / endnotes, it would be much appreciated.

-HQ

 

[SkipVought]

I'm not at all sure about this part...

[b]wrdSelection.Find.Text.Font.Bold[/b] = .Cells(row, 2).Font.Bold

Check out this tool to help you debug, faq707-4594

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[macropod]

Hi,

I'd have though you needed something more along the lines of:

With ActiveSheet
Dim FindText As String, NewText As String, Bold As Boolean, Ital As Boolean, Colr As Boolean
  For Row = 2 To totalrows Step 1
    FindText = .Cells(Row, 1).Value
    With .Cells(Row, 2)
      NewText = .Value
      Bold = .Font.Bold
      Ital = .Font.Italic
      Colr = .Font.Color
    End With
    With wrdSelection.Find
      .Text = FindText
      With .Replacement
        .Text = NewText
        .Font.Bold = Bold
        .Font.Italic = Ital
        .Font.Color = Colr
      End With
      .Execute Replace:=wdReplaceAll
    End With
  Next Row
End With

Cheers
[MS MVP - Word]

 

[huangqi01]

Thanks macprod,

I may have something else in the code wrong, but this code does not seem to work. I am getting a runtime error 94 - (Invalid use of Null).
Ital = .Font.Italic is highlighted.


Any help would be great.

-Jason

 

[SkipVought]

Are you sure its THAT statement and not the Colr statement? Colr should not be declared as Boolean. Rather Variant.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[macropod]

Hi Jason,

You'll get that error if only some of the text has the attribute being tested. This will apply to all of the font attributes you're interested in.

You'll probably need to change:
Colr As Boolean
to:
Colr As Long

And you might also want to add:
Ulin = .Font.Underline
and:
.Font.Underline = Ulin
in the appropriate places.

If the attributes issue is going to be a problem because the source cell can't be relied on to have uniform character formatting, you'll need to take a different approach. For example, you could copy the reference cell, find the relevant location in the Word document and paste the cell's contents there as formatted text.


Cheers
[MS MVP - Word]

 

[huangqi01]

Macropos said,

"... you'll need to take a different approach. For example, you could copy the reference cell, find the relevant location in the Word document and paste the cell's contents there as formatted text. "

Yes... This is what I need, how do I do this?

-Jason

 

[macropod]

Hi Jason,

You could use something like:

Dim FindText As String, NewText As Variant
With ActiveSheet
  For Row = 2 To TotalRows
    FindText = .Cells(Row, 1).Value
    NewText = .Cells(Row, 2).Copy
    With wrdSelection
      With .Find
        .ClearFormatting
        .Text = FindText
        .Forward = True
        .Wrap = 0 'wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
      End With
      Do While .Find.Found
        .PasteSpecial DataType:=1 'wdPasteRTF
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
  Next Row
End With

Of course, if you can be sure all of Word's Find defaults are in effect, you can delete those parts of the Find statement that you don't need.


Cheers
[MS MVP - Word]