Word and Excel Mailmerge - run from Excel - includes search and replace with change of text colour but doesn't work

Question

I am wanting to run a mailmerge from an Excel Macro

the aims of the macro are

1. Open the mailmerge template (this works)
2. Link the Excel data file. (this works)
3. Run the mailmerge for each record in turn and save each resulting file using one of the data fields (this works for the first record only so far).
4. On each document, do a search and replace of a word e.g. green_ and replace it with a green bullet (the search and replace works, creating the bullet but not making it the colour). This is using adapted code froma Word Macro which does work.

The code is here:

Sub runmergeforWeeklyHR()
' 1) Merges active record and saves the resulting document named by the project id
' 2) Closes the resulting document, and continue to merge next record.
' 3) Replaces Rag Status Text with coloured bullets
' 4)Advances to the next record in the datasource
'


    Dim xls As Excel.Application
    Dim WorkingDirectory As String
    Dim TemporaryStor As String
    Dim ReportPeriod  As String
    Dim ProjRef As String
    Dim WordTemplate As String
    Dim ExcelDataFile As String
    Dim HRFilename As String


    WorkingDirectory = "U:\weekly HR\"
    TemporaryStor = WorkingDirectory + "TempFolderforWeeklyReps"
    WordTemplate = WorkingDirectory + "Weekly Highlight Report template.docm"
    ExcelDataFile = WorkingDirectory + "PMO Project Reporting spreadsheet - for mailmerge.xls"

    Set xls = New Excel.Application

'This opens a new instance of Word and opens a document
'To change what document is opened, edit the WordTemplate
DisplayAlerts = none
Dim objWord As Object
Set objWord = Nothing


Set objWord = CreateObject("Word.Application")


objWord.Visible = True

Dim wordtmpl As Document
Set wordtmpl = Nothing
Set wordtmpl = objWord.Documents.Open(WordTemplate)

' link document to data source
wordtmpl.MailMerge.MainDocumentType = wdFormLetters
wordtmpl.MailMerge.OpenDataSource Name:=ExcelDataFile, _
SQLStatement:="SELECT * FROM `Work Data$`"


'perform mail merge
      With ActiveDocument.MailMerge
          .Destination = wdSendToNewDocument
          .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            ReportPeriod = .DataFields("Weekly_Reporting_Period").Value
            ProjRef = .DataFields("Work_ID_").Value

            'Select data for report file names.
            HRFilename = ProjRef + "_Weekly_Highlight_Report"
        End With
            ' Merge the active record
            .Execute Pause:=False

 'Update Rag Status with coloured bullet
    objWord.Application.Selection.Find.ClearFormatting
    objWord.Application.Selection.Find.Replacement.ClearFormatting
    With objWord.Application.Selection.Find.Replacement.Font.Color = 5287936
    With objWord.Application.Selection.Find
        .Text = "green_"
        .Replacement.Text = ChrW(9679)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        End With
      objWord.Application.Selection.Find.Execute Replace:=wdReplaceAll
    End With

    objWord.Application.Selection.Find.ClearFormatting
    objWord.Application.Selection.Find.Replacement.ClearFormatting
    With objWord.Application.Selection.Find.Replacement.Font.Color = 49407
        With objWord.Application.Selection.Find
        .Text = "amber_"
        .Replacement.Text = ChrW(9679)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        End With
     objWord.Application.Selection.Find.Execute Replace:=wdReplaceAll

    End With

    objWord.Application.Selection.Find.ClearFormatting
    objWord.Application.Selection.Find.Replacement.ClearFormatting
    With objWord.Application.Selection.Find.Replacement.Font.Color = wdColorRed
         With objWord.Application.Selection.Find
        .Text = "red_"
        .Replacement.Text = ChrW(9679)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        End With
      objWord.Application.Selection.Find.Execute Replace:=wdReplaceAll
    End With


    ' Save the resulting document.
            ActiveDocument.SaveAs2 Filename:=TemporaryStor + "\" + HRFilename, FileFormat:= _
                wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
                :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
                :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
            SaveAsAOCELetter:=False, CompatibilityMode:=14
     End With
    ' Now, back in the template document, advance to next record
 '   WordTemplate.MailMerge.DataSource.ActiveRecord = wdNextRecord
End Sub

Can anyone help please. I have searched, but nothing I have found solves my problem.

Answer 1

I don't have time to test this, but I think the problem is with the way you have done the With statements. Try putting everything in the same With block like this:

     With objWord.Application.Selection.Find
     .ClearFormatting
     .Replacement.ClearFormatting
    .Replacement.Font.Color = wdColorRed
    .Text = "red_"
    .Replacement.Text = ChrW(9679)
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    End With

EDIT**

THis will loop through the records. Again, I don't really have time to modify this to make it do exactly what you want, but it will point you on the right track. Dim mergedDoc As Word.Document Dim numrecords As Integer

numrecords = 'count the numbr of records using excel sheet.
For i = 1 to numrecords
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = i
            .LastRecord = i
            ReportPeriod = .DataFields("Weekly_Reporting_Period").Value
            ProjRef = .DataFields("Work_ID_").Value

        'Select data for report file names.
        HRFilename = ProjRef + "_Weekly_Highlight_Report"
    End With
        ' Merge the active record
        .Execute Pause:=False
 Set MergedDoc = ObjWord.ActiveDocument 'You need to get the document you just made if you want to save it.
'You want to do all of your formatting to the created merged doc, so change all of your color changing code to the mergeddoc and then save....
Next i