Question

我是VBA的完全新手，非常感谢帮助自动化流程，如果有人会如此善良。：）

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

我找到了一些代码，这些代码会让我打开我的Word模板，但就我能说的而言:(大声笑

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

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

我在Word中设置了书签，并命名了我要复制的单元格。

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

非常感谢任何帮助。

提前致谢：）

邓肯

Answer 1

我有代码可以做这样的事情。在Word中，我只使用一个特殊标记（如<<NAME>>）而不是使用书签替换字段。

你可能需要适应。我使用ListObject（新的Excel＆＃34; Tables＆＃34;），如果你使用一个简单的Range，你可以改变它。

创建＆＃34; Template.docx＆＃34;文档，将其设置为只读，并将可替换字段放在那里（<<NAME>>等）。一个简单的docx会做，它不一定是一个真正的模板（dotx）。

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

这基本上复制了代码中的邮件合并功能，为您提供更多控制。

自动化从Excel填充单词模板的过程所需的帮助

1 个答案: