将单元格的内容替换到Word文档中

作者：iamlaosong

业务部门需要每天发通报，通报内容基本相同，只是里面的数值有变化，分析略有不同。如果人工将单元格的数值复制到文本中，是一件很费时费力的事，关键是每天要做，不胜其烦。为此，我写了一个宏，点击一下按钮，几十个数值就替换到模板文档当中去了，方便快捷，而且不会出错。

方法是在模板文档中需要替换的地方，写上单元格名称，以方便查找替换。如下图所示：

在Excel工作表中将所有的要替换的单元格列表，暂时用不上的也列上，将来需要，只需改变模板文档中的单元格名称就行了。增加一个按钮，编辑一个宏就可以实现快速替换了，替换后保存为新文件即可。如下图：

代码如下（注意：取单元格的值时要加上Text属性：rngValue = Range(rngName).Text）：

'将Word文档中单元格名称替换成单元格内容
'Created by iamlaosong 20200721
'
Sub get_data()
    Dim WordApp As Object, DocApp As Object     '定义类
    Dim DatFile, ModFile, rngName As String
    Dim rngValue, i, j As Integer
    Dim rngArr()
    
    Set WordApp = CreateObject("Word.Application")   '新建Word对象
    WordApp.Visible = True
    'modfile = "跟单专项重点问题专报-模板.doc"
    thisfile = ThisWorkbook.Name   '本文件的名字，这样赋值就可以随便改名了
    Worksheets("通报表").Select
    rngArr = Range("B51:K68").Value
    ModFile = Cells(50, 2)                             '模板文件名称
    DatFile = Cells(50, 8)                             '生成文件名称
    modFullName = ThisWorkbook.Path & "\" & ModFile
    datFullName = ThisWorkbook.Path & "\" & DatFile
    'Set WordD = WordApp.Documents.Add                  '新建文档
    'Set WordD = Wordapp.Documents.open(filename)          '打开文档
    
    If Dir(modFullName, vbNormal) <> vbNullString Then
        Set DocApp = WordApp.Documents.Open(modFullName)
    Else
        MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If

    For i = 1 To 18
        For j = 1 To 10
            rngName = rngArr(i, j)
            If rngName <> "" Then
                rngValue = Range(rngName).Text
                With WordApp.Selection.Find
                    .ClearFormatting
                    .Text = rngName
                    .Replacement.Text = rngValue
                    .Forward = True
                    .Wrap = wdFindContinue
                    .MatchWildcards = False
                End With
                WordApp.Selection.Find.Execute Replace:=wdReplaceAll
            End If
        Next j
    Next i
    'Windows(Modfile).Activate
    WordApp.ActiveDocument.SaveAs datFullName
    'WordApp.ActiveDocument.Save    '保存当前文档
    'WordApp.Documents.Save         '保存所有文档
    WordApp.Documents.Close
    WordApp.Quit
End Sub