Vba 自动化从Excel填充word模板的过程中需要的帮助

我是VBA的新手，如果有人愿意的话，我会非常感谢您对自动化流程的帮助。：）

我正在尝试从我创建的excel电子表格中填充Word模板

我找到了一些代码，可以让我打开我的Word模板，但这是我所能做到的：（哈哈

我希望实现的下一步是将某些单元格中的数据复制并粘贴到Word文档中

我已经在Word中设置了书签，并命名了我希望复制的单元格

某些单元格包含文本，其他单元格包含生成数字答案的公式/和。在包含公式或和的单元格中，我要将答案复制到Word

任何帮助都将不胜感激

提前感谢：）

---

邓肯

我有这样的代码。在Word中，我没有使用书签替换字段，而是使用了一个特殊的标记（如

）

你可能需要适应。我使用一个ListObject（新的Excel“表”），如果使用一个简单的范围，您可以更改它

创建一个“Template.docx”文档，将其设置为只读，并将可替换字段放在那里（

等）。一个简单的docx就可以了，它不必是真正的模板（dotx）

公共子写入模板（）
常数colNum=1
常数colName=2
常数colField2=3
Const cBasePath=“c:\SomeDir”
Dim wordDoc作为对象，sFile作为字符串，Name作为字符串
将lo调暗为ListObject，将LOW调暗为ListRow
以滴度表示的暗淡项目
Set lo=ActiveCell.ListObject
设置Row=ActiveCell.ListObject.ListRows（ActiveCell.Row-lo.Range.Row）
用现在的射程
'我使用其中一列作为文件名：
Debug.Print“writing”和theRow.Range.Cells（1，colName.text）
'文件名不能包含以下任何字符：\/：*？" < > |
名称=替换（.Cells（1，colName），“？”，“”）
名称=替换（名称“*”，“”）
名称=替换（名称“/”，“-”）
名称=替换（名称“：”，“；”）
名称=替换（名称“，”）
sFile=（cBasePath&“\”Name）&“.docx”
调试。打印sFile
设置wordApp=CreateObject（“word.Application”）
如果Dir（sFile）“，则”文件已存在
设置wordDoc=wordApp.Documents.Open（sFile）
可见=True
wordApp.Activate
Else的新文件
设置wordDoc=wordApp.Documents.Open（cBasePath&“\”&“Template.docx”）
wordApp.Selection.Find.Execute Forward:=（wordApp.Selection.Start=0），FindText:=“«NUM»”，替换为：=.Cells（1，colNum）
wordApp.Selection.Collapseend的折叠方向：=1'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:=“««名称»”，替换为：=.Cells（1，colName）
wordApp.Selection.Collapseend的折叠方向：=1'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:=“««字段2»”，替换为：=.单元格（1，colField2）
wordDoc.ListParations.item（1）.Range.Select
wordApp.Selection.Collapseend的折叠方向：=1'wdCollapseEnd
可见=True
wordApp.Activate
出错时继续下一步
'如果失败（例如，缺少目录），文件将不保存，Word将询问名称。
wordDoc.SaveAs sFile'文件名：=（cBasePath&“\”&.Cells（1，colName））
错误转到0
如果结束
以
端接头

---

这基本上是在代码中复制邮件合并功能，以提供更多的控制。

Mailmerge可以做到这一点。书签和命名范围是否相同（匹配）名称？-举个例子。你想为所有书签或所有命名区域运行它吗？换句话说，什么将定义你的宏的范围？嗨，KazJaw，谢谢你的消息。是的，我为书签和命名单元格使用了相同的名称。例如，我的第一个书签名为Sample_1，我用它来命名我想从中命名的单元格导出数据。我有7个书签，我希望将数据传输到其中，每个书签在excel中都有一个同名的姊妹单元格。

Private Sub PrintHDR_Click()

Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

objWord.Documents.Open "C:\Users\Duncan\Desktop\HDR.dotx"

End Sub

Public Sub WriteToTemplate()
    Const colNum = 1
    Const colName = 2
    Const colField2 = 3
    Const cBasePath = "c:\SomeDir"

    Dim wordDoc As Object, sFile As String, Name As String
    Dim lo As ListObject, theRow As ListRow
    Dim item As tItem

    Set lo = ActiveCell.ListObject
    Set theRow = ActiveCell.ListObject.ListRows(ActiveCell.Row - lo.Range.Row)
    With theRow.Range
        'I use one of the columns for the filename:
        Debug.Print "writing " & theRow.Range.Cells(1, colName).text

        'A filename cannot contain any of the following characters:     \ / : * ? " < > |
        Name = Replace(.Cells(1, colName), "?", "")
        Name = Replace(Name, "*", "")
        Name = Replace(Name, "/", "-")
        Name = Replace(Name, ":", ";")
        Name = Replace(Name, """", "'")

        sFile = (cBasePath & "\" & Name) & ".docx"
        Debug.Print sFile

        Set wordApp = CreateObject("word.Application")

        If Dir(sFile) <> "" Then 'file already exists
            Set wordDoc = wordApp.Documents.Open(sFile)
            wordApp.Visible = True
            wordApp.Activate
        Else 'new file
            Set wordDoc = wordApp.Documents.Open(cBasePath & "\" & "Template.docx")
            wordApp.Selection.Find.Execute Forward:=(wordApp.Selection.Start = 0), FindText:="««NUM»»", ReplaceWith:=.Cells(1, colNum)

            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Selection.Find.Execute FindText:="««NAME»»", ReplaceWith:=.Cells(1, colName)

            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Selection.Find.Execute FindText:="««FIELD2»»", ReplaceWith:=.Cells(1, colField2)

            wordDoc.ListParagraphs.item(1).Range.Select
            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Visible = True
            wordApp.Activate
            On Error Resume Next
            'if this fails (missing directory, for example), file will be unsaved, and Word will ask for name.
            wordDoc.SaveAs sFile 'Filename:=(cBasePath & "\" & .Cells(1, colName))
            On Error GoTo 0
        End If
    End With
End Sub