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

我是VBA的一名新手，如果有人愿意，我会很感激自动化一个过程的一些帮助。 🙂

我正在尝试从我创build的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中，而不是使用书签的字段来replace，我只是使用一个特殊的标记（如<<NAME>> ）。

你可能不得不适应。 我使用ListObject（新的Excel“表”），如果使用简单的Range，则可以更改该对象。

创build一个“Template.docx”文档，使其成为只读文件，并在那里放置可replace的字段（ <<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 

这基本上复制代码中的邮件合并function，给你更多的控制。