VBA读取excel数据按照word模板生成文档，无法替换问题

[xjauto]

以下是我的程序，需要从excel中读取相应的数据替换word模板中对应的字段，然后生成新文档。

出现问题：

    1）读取excel数据没有问题；读取word模板没有问题；另存为新word文档也没有问题。

    2）无法完成替换字段，请各位大佬给看看问题出现中哪里；

 

 

 

 

Private Sub CommandButton1_Click() '这个位置按照自己控件修改，例如
    '我的控件名称为"CommandButton1"，自动生成了Private Sub CommandButton1_Click()
    '肯定会自动生成，如果打开之后发现是个空白框，请先添加按钮控件后，再查看代码
On Error GoTo Err_cmdExportToWord_Click
    Dim objApp As Object 'Word.Application
    Dim objDoc As Object 'Word.Document
    Dim objDoc1 As Object 'Word.Document

    Dim objDocOrigin As Object 'Word.Document
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim strTemplates As String '模板文件路径名
    Dim strFileName As String '将数据导出到此文件
    Dim strData As String 'excel数据文件路径名
    Dim i As Integer '用来循环遍历，选中姓名的起始行号
    Dim j As Integer '用来循环遍历，选中区域的总行数
    Dim k As Integer '用来循环遍历，选择区域遍历的行号

    Dim Num As String '定义变量，序号
    Dim Name As String '定义变量，姓名
    Dim Fname As String '定义变量家属姓名
    Dim Pname As String '定义变量所在党组织全称
    Dim Rela As String '定义变量主要关系

    Dim data_areas As Range
    Dim total_data As Integer
    Dim result As String
    Dim n As Long '用来循环遍历
    
    Dim foundRange As Range '选择查到的文本
   
    Set data_areas = Application.InputBox(prompt:="请鼠标选择需要输出数据的区域", Title:="选择", Type:=8) '选取输出的数据区域
    i = data_areas.Row     '获取选取区域开始行所在行号
    j = data_areas.Rows.Count '  获取选取区域总行数
    over4Names = ""
   
    '如果希望不弹框选择文件和存放目录可以将下面三行前面的单引号去除，再将下面一段弹框选择文件的代码删除
    'strTemplates = "C:\Users\80668\Desktop\template.docx"
    'strData = "C:\Users\80668\data.xlsx"
    'Path = "C:\Users\80668\Desktop\报告20210113"
    
    '下面的一段代码是弹出3次框，分别选择模板文件doc，检测数据文件excel，报告存放目录
    With Application.FileDialog(msoFileDialogFilePicker) '选择word模板文件
         .Filters.Add "word文件", "*.doc*", 1
         .AllowMultiSelect = False
         If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
    End With
    With Application.FileDialog(msoFileDialogFilePicker) '选择excel文件
         .Filters.Add "word文件", "*.xls*", 1
         .AllowMultiSelect = False
         If .Show Then strData = .SelectedItems(1) Else Exit Sub
    End With
    With Application.FileDialog(msoFileDialogFolderPicker)  '获取输出的文件存储路径
         Path = ThisWorkbook.Path
    End With
   
   ' 忽略告警加快速度
   With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = False
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open(strData)
    xlApp.Visible = False
    '下面去检测记录文件的第一个Sheet，可以通过名字取对应的sheet，例如xlBook.Worksheets("Sheet1")
    Set xlSheet = xlBook.Worksheets(1)
    
   ' 将检测表第4列的姓名数据全部取出来放到数组里面，遍历数组速度比遍历xlSheet速度要快很多
    nameArray = xlSheet.Range("D1:D" & xlSheet.Cells(Rows.Count, "D").End(xlUp).Row).Value
    
    ' 开始遍历选择的姓名和身份证
    For k = i To i + j - 1
      Num = Cells(k, 1) '序号'
      Name = Cells(k, 4) '姓名'
      Pname = Cells(k, 7) '所在党组织的全称'
      Rela = Cells(k, 5) '主要关系'
      Fname = Cells(k, 6) '家属姓名'

    Set objDoc = objApp.Documents.Open(strTemplates, , False)
    
    'Set objDoc1 = objDoc.Range
    'Set objDoc2 = objDoc.Range
    'Set objDoc3 = objDoc.Range
    'Set objDoc4 = objDoc.Range
    
    
    
    '定义文件命名规则：序号_姓名+主要关系
    strFileName = Num & "_" & Name & Rela & ".docx"
     '文件名必须包括“.docx”的文件扩展名，如没有则自动加上
     If Not strFileName Like "*.docx" Then strFileName = strFileName & ".docx"
     '如果文件已存在，则删除已有文件
     If Dir(strFileName) <> "" Then Kill strFileName
     '打开模板文件

    '将写入数据的模板另存为文档文件
    'objDoc.SaveAs Path & "\" & strFileName
    'objDoc.Saved = True
    'objDoc.Close
    'objApp.Quit
    
    'Set objApp = CreateObject("Word.Application")
    'objApp.Visible = False
    'Set objDoc1 = objApp.Documents.Open(Path & "\" & strFileName, , False)

    '开始替换模板预置变量文本
    'With objApp.Application.Selection
     
    ' With objDoc.Content.Find
       ' .Find.ClearFormatting
       ' .Find.Replacement.ClearFormatting
      '  .Find.Wrap = wdFindContinue  ' 当到达文档末尾时继续搜索
           
        With objDoc.Content.Find
           .Text = "{$Pname}"
           .Forward = True
           .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
            .Format = False
            .MatchCase = False   ' 不区分大小写
            .MatchWholeWord = False ' 不匹配整个单词
            .MatchByte = True
            .MatchWildcards = False ' 不使用通配符
            .MatchSoundsLike = False ' 不使用发音相似的搜索
            .MatchAllWordForms = False ' 不匹配所有词形
          
           
           If .Execute Then
              .Replacement.Text = Pname
              
              .Wrap = wdFindContinue  ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
              .Execute Replace:=wdReplaceAll ' wdReplaceAll 表示替换所有找到的实例
              'Set foundRange = .Parent
              'foundRange.HighlightColorIndex = wdYellow ' 高亮显示找到的文本
           Else
               MsgBox "未找到指定的文本0。"
           End If
        End With
        '.Execute Replace:=wdReplaceAll
 
        With objDoc.Content.Find
           .Text = "{$Fname}"
         
           .Forward = True
           .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
            .Format = False
            .MatchCase = False   ' 不区分大小写
            .MatchWholeWord = False ' 不匹配整个单词
            .MatchByte = True
            .MatchWildcards = False ' 不使用通配符
            .MatchSoundsLike = False ' 不使用发音相似的搜索
            .MatchAllWordForms = False ' 不匹配所有词形
           
           If .Execute Then
              .Replacement.Text = Fname
              .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
              .Execute Replace:=wdReplaceAll
           Else
               MsgBox "未找到指定的文本1。"
           End If
        End With
        '.Find.Execute Replace:=wdReplaceAll
        
        With objDoc.Content.Find
           .Text = "{$Name}"
         
           .Forward = True
           .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
            .Format = False
            .MatchCase = False   ' 不区分大小写
            .MatchWholeWord = False ' 不匹配整个单词
            .MatchByte = True
            .MatchWildcards = False ' 不使用通配符
            .MatchSoundsLike = False ' 不使用发音相似的搜索
            .MatchAllWordForms = False ' 不匹配所有词形
          
          If .Execute Then
              .Replacement.Text = Name
              .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
              .Execute Replace:=wdReplaceAll
           Else
               MsgBox "未找到指定的文本2。"
           End If
        End With
        '.Find.Execute Replace:=wdReplaceAll
        
        With objDoc.Content.Find
           .Text = "{$Rela}"
           .Forward = True
           .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
            .Format = False
            .MatchCase = False   ' 不区分大小写
            .MatchWholeWord = False ' 不匹配整个单词
            .MatchByte = True
            .MatchWildcards = False ' 不使用通配符
            .MatchSoundsLike = False ' 不使用发音相似的搜索
            .MatchAllWordForms = False ' 不匹配所有词形
          If .Execute Then
              .Replacement.Text = Rela
              .Wrap = wdFindContinue         ' wdFindContinue 表示在到达文档末尾后继续在文档开头查找
              .Execute Replace:=wdReplaceAll
           Else
               MsgBox "未找到指定的文本3。"
           End If
        End With
        '.Find.Execute Replace:=wdReplaceAll
               
           
    'End With
 
    '将写入数据的模板另存为文档文件
    objDoc.SaveAs Path & "\" & strFileName
    objDoc.Saved = True
    
    Next
    objDoc.Close
    
    
     '将写入数据的模板另存为文档文件
    'objDoc.SaveAs Path & "\" & strFileName
    'objDoc.Saved = True
    
    'Next
    'objDoc.Close
       
  
   '将先前的忽略告警恢复为true
   With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    result = "报告生成完毕！"
    
    MsgBox result, vbYes + vbExclamation
Exit_cmdExportToWord_Click:
    objApp.Quit
    xlApp.Quit
    Set objApp = Nothing
    Set objDoc = Nothing
    Set objTable = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
Err_cmdExportToWord_Click:
    MsgBox Err.Description, vbCritical, "出错"
    Resume Exit_cmdExportToWord_Click
End Sub