Word和Excel邮件合并-从Excel运行-包括搜索和替换为文本颜色的更改，但不'；行不通

我想从Excel宏运行邮件合并

宏的目标是

打开邮件合并模板（此操作有效）

链接Excel数据文件。（本工程）

依次为每条记录运行mailmerge，并使用其中一个数据字段保存每个生成的文件（目前为止，这仅适用于第一条记录）

在每个文档上，搜索并替换一个单词，例如green_u，并用绿色项目符号替换它（搜索和替换工作，创建项目符号，但不使其成为颜色）。这是使用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

---

谁能帮忙吗。我已经搜索过了，但没有发现任何东西可以解决我的问题。

我没有时间来测试这个，但我认为问题在于您处理语句的方式。尝试将所有内容都放在相同的块中，如下所示：

     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作为Word.Document Dim numrecords为整数

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模板之前不小心碰到了它，它会出错，有什么想法我可以先关闭该文档，也就是这个文档，我想它在打开任何Word文档时都会出错（我已经尝试过很多次了，它变得模糊了）。如果此代码行中发生错误，则可以包含errorhandling。然后，您需要找到活动的openword实例。您必须搜索所有打开的应用程序，直到找到为止。我不记得做这件事的语法，但我相信谷歌会有所帮助。或者，您可以将模板保留在一个位置，让宏将模板复制到某个位置，然后打开复制的文件。这样，可以保证模板不会打开。