Word 和 Excel 邮件合并 - 运行来自 Excel - 包括搜索和替换文本颜色的更改，但不起作用

Question

我想要运行来自 Excel 宏的邮件合并

宏的目标是

打开邮件合并模板（有效）
Link Excel 数据文件。（这个有效）
运行依次对每条记录进行邮件合并，并使用其中一个数据字段保存每个结果文件（目前仅适用于第一条记录）。
在每个文档上，搜索并替换一个词，例如green_ 并将其替换为绿色项目符号（搜索和替换工作，创建项目符号但不使其成为颜色）。这是使用来自确实有效的 Word 宏的改编代码。

代码在这里：

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

谁能帮忙。我已经搜索过了，但没有找到解决我问题的方法。

Answer 1

我没有时间对此进行测试，但我认为问题在于您完成 With 语句的方式。尝试将所有内容都放在同一个 With 块中，如下所示：

     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

编辑**

这将遍历记录。同样，我真的没有时间修改它以使其完全符合您的要求，但它会为您指明正确的轨道。 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

Word 和 Excel 邮件合并 - 运行来自 Excel - 包括搜索和替换文本颜色的更改，但不起作用

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

excel

vba

replace

mailmerge

Word 和 Excel 邮件合并 - 运行 来自 Excel - 包括搜索和替换文本颜色的更改，但不起作用

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

excel

vba

replace

mailmerge

Word 和 Excel 邮件合并 - 运行来自 Excel - 包括搜索和替换文本颜色的更改，但不起作用