怎样用Excel的vba向word文档插入数据源

是玩都不精

压缩文件中有一个word文档和一张Excel表，表中我做了个按钮，想点击后能在word文档中实现邮件合并功能，在“同学”前加上获奖者姓名，“比赛”前加上项目名称，“等奖”前加上获奖等级。研究多时未得其门，请大神出手！！！注意是用Excel操作word，不是在Word中使用邮件合并功能。先谢了。 怎样用Excel的vba向word文档插入数据源.rar (27.76 KB, 下载次数: 11)

2024-1-9 11:04 上传

点击文件名下载附件

tmplinshi

gwjkkkkk

参与一下。。。

是玩都不精

tmplinshi 发表于 2024-1-10 00:43

tmplinshi老兄好。仔细研学了你的代码，可以运行，达到了我需要的效果。每个功能还特意加上了提示，我非常感动。在此真心拜谢。不过你用的方法不是我想用的，一小时后我把我原始的模板、数据源发给你，请你看看能否在Excel中调用Word的邮件合并的功能。

是玩都不精

tmplinshi 发表于 2024-1-10 00:43

压缩文件中有一张表和三个模板，表中有几个不同项目的获奖信息。打开表后点击“加载项”、“显示窗体”，分别选择模板和sheet后，完成邮件合并。但运行到红色语句时错误。请老兄看看怎样修改。源代码如下：

1. 
   
2. Private Sub UserForm_Initialize()
   
3. Dim myFiles, sh As Worksheet, myArr
   
4. myFile = Dir(ThisWorkbook.Path & "\*.docx")
   
5. Do While myFile <> ""
   
6.     myFile = Dir:        n = n + 1
   
7. Loop
   
8. ReDim myFiles(n)
   
9. myFile = Dir(ThisWorkbook.Path & "\*.docx")
   
10. n = 0
    
11. Do While myFile <> ""
    
12.     myFiles(n) = myFile:        n = n + 1:      myFile = Dir
    
13. Loop
    
14. 模板名称.List = myFiles
    
15. 
    
16. s = Worksheets.Count - 1:    n = 0
    
17. ReDim myArr(s)
    
18.     For Each sh In Worksheets
    
19.         If sh.Name <> "评委打分" Then
    
20.             myArr(n) = sh.Name:     n = n + 1
    
21.         End If
    
22.     Next
    
23. 表单名称.List = myArr:      Erase myArr
    
24. End Sub
    
25. 
    
26. Private Sub 取消_Click()
    
27. Unload Me
    
28. End Sub
    
29. 
    
30. Private Sub 确定_Click()
    
31. Unload Me
    
32. Application.DisplayAlerts = xlAlertsNone
    
33. Application.ScreenUpdating = False
    
34. 
    
35. Dim wordApp As New Word.Application
    
36. mySource = ThisWorkbook.Path & "\获奖名单.xlsm"
    
37. wordApp.Documents.Open (ThisWorkbook.Path & "" & 模板名称)
    
38. wordApp.ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    
39. wordApp.Visible = True
    
40. Set doc = GetObject(ThisWorkbook.Path & "" & 模板名称)
    
41. doc.MailMerge.OpenDataSource Name:= _
    
42.     mySource, LinkToSource:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    
43.     & mySource & ";Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:Engine Type=35;Jet OLEDB:Databas" _
    
44.     , SQLStatement:="SELECT * FROM `'" & 表单名称.Value & "$'`", SubType:=wdMergeSubTypeAccess
    
45. wordApp.Documents.Application.Activate
    
46. 
    
47. With wordApp.ActiveDocument.ActiveWindow.Selection
    
48.     .HomeKey Unit:=wdStory
    
49.     [color=Red]wordApp.Selection.MailMerge.Fields.Add Range:=Selection.Range, Name:="获奖者"[/color]
    
50.     If ActiveDocument.Name = "书法证书.doc" Then
    
51.         myArr1 = Array("度", "荣获"):       myArr2 = Array("组别", "获奖等级")
    
52.         For n = 0 To UBound(myArr1)
    
53.             If .Find.Execute(findtext:=myArr1(n), Forward:=True) Then
    
54.                 Selection.MoveRight Unit:=wdCharacter, Count:=1
    
55.                 ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(n)
    
56.             End If
    
57.         Next
    
58.     ElseIf ActiveDocument.Name = "运动会模板.doc" Then
    
59.         myArr1 = Array("荣获", "项目"):     myArr2 = Array("年级", "组别", "项目名称", "获奖等级")
    
60.         For n = 0 To UBound(myArr1)
    
61.             If .Find.Execute(findtext:=myArr1(n), Forward:=True) Then
    
62.                 .MoveRight Unit:=wdCharacter, Count:=1
    
63.                 If n = 0 Then
    
64.                     ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(0)
    
65.                     ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(1)
    
66.                     ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(2)
    
67.                 Else
    
68.                     ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(3)
    
69.                 End If
    
70.             End If
    
71.         Next
    
72.     Else
    
73.         myArr1 = Array("在", "第"):       myArr2 = Array("学年度", "学期")
    
74.         For n = 0 To UBound(myArr1)
    
75.             If .Find.Execute(findtext:=myArr1(n), Forward:=True) Then
    
76.                 Selection.MoveRight Unit:=wdCharacter, Count:=1
    
77.                 ActiveDocument.MailMerge.Fields.Add Range:=Selection.Range, Name:=myArr2(n)
    
78.             End If
    
79.         Next
    
80.     End If
    
81. End With
    
82. 
    
83. With ActiveDocument.MailMerge
    
84.     .Destination = wdSendToNewDocument:        .SuppressBlankLines = True
    
85.     With .DataSource
    
86.         .FirstRecord = wdDefaultFirstRecord:            .LastRecord = wdDefaultLastRecord
    
87.     End With
    
88.     .Execute Pause:=False
    
89. End With
    
90. Application.DisplayAlerts = wdAlertsAll:        Application.ScreenUpdating = True
    
91. End Sub
    
92. 
    

复制代码

是玩都不精

感谢tmplinshi和gwjkkkkk两位老兄的帮助。下面是我的原始文件，模板有几个，作为数据源的表中也有几张sheet。打开表后点击“加载项”、“显示窗体”、选择模板和表单后，点击确定提示错误。我认为这种方法对于处理模板多、比赛项目多的工作是最方便的。还请各位大神相助！！！

liuxi001

是玩都不精 发表于 2024-1-11 11:15
感谢tmplinshi和gwjkkkkk两位老兄的帮助。下面是我的原始文件，模板有几个，作为数据源的表中也有几张sheet ...

获奖名单.zip (25.56 KB, 下载次数: 7)

2024-1-13 00:55 上传

点击文件名下载附件

可能是对象指代不明吧，测试三好学生。

是玩都不精

liuxi001 发表于 2024-1-13 00:56
可能是对象指代不明吧，测试三好学生。

就是不知道怎样在Excel中指定Word对象并插入合并域。你的代码在Word中可以运行，但通过Excel使用就不行了。不过仍然感谢你的关注。

liuxi001

是玩都不精 发表于 2024-1-15 16:18
就是不知道怎样在Excel中指定Word对象并插入合并域。你的代码在Word中可以运行，但通过Excel使用就不行了 ...

只改了你窗体中三好学生部分的代码，并没有在word中写代码，office365测试没有问题。