一对多邮件合并与图片插入

灵犀之声

一、一对多邮件合并
1.处理数据：添加辅助列，=IF(A3=A2,1,0) （数据的重复性标注）
     2.邮件插入对应的域
     3.邮件：规则，设置书签A，值为1。
     4.选中1，添加需要插入的域。
     5.添加下一条记录：域名选择辅助，等于，1.
     6.规则：如果…那么…否则：域名选择辅助=1，插入文字可随意输入。
     7.将辅助改为A，选中插入的文字部分，插入相应的域。
     8.第二列后只需重复第六步第七部即可。
      
     
二、邮件合并插入图片
（1）将照片和Excel表格、Word文档放在同一目录下，Excel表格里面需要标明图片名称（带后缀全称）
     （2）执行Word文件邮件合并功能
     （3）插入→文档部件→域，选择IncludePicture，在文件名称或URL输入图片所在地址
     （4）按Alt+F9切换到域代码，在图片路径后面输入两个\\，执行插入合并域，选择照片
     （5）按Alt+F9切换到正常模式，执行邮件合并，最后全选，按F9刷新即可

灵犀之声

欢迎各位参与讨论

wangqh8203

我是用纯代码来解决一对多的数据合并。
第一：辅助列最后会有很多空行，表格不美观。
第二：后期还需要单独拆分成独立文件，还需要发给其他人。
操作步骤：提前把数据源合并好，Word模板表格配置分组后最大的行数，配置需要分组的列号（FieldColumn），运行就可以了。

1. Sub myMailMerge()
   
2. Dim i As Byte, r As Integer, intCount As Integer, FieldColumn As Byte, HeadName As String
   
3. Dim MyPath As String
   
4. Dim arr()
   
5. Dim dic As Object
   
6. 
   
7. Application.ScreenUpdating = False
   
8. Set dic = CreateObject("Scripting.Dictionary")
   
9. MyPath = ThisDocument.Path
   
10. If (ThisDocument.MailMerge.State = 0) Then
    
11.     MsgBox ("没有合并数据源！")
    
12.     Exit Sub
    
13. End If
    
14. 
    
15. '设置分组字段的列号
    
16. FieldColumn = 4
    
17. intCount = 0
    
18. With ThisDocument.MailMerge.DataSource
    
19.     .ActiveRecord = wdFirstRecord
    
20.     Do
    
21. dic(.DataFields(FieldColumn).Value) = .DataFields(FieldColumn).Value
    
22.         intCount = intCount + 1
    
23.         .ActiveRecord = wdNextRecord
    
24.     Loop Until intCount = .RecordCount
    
25.     HeadName = .FieldNames(FieldColumn)
    
26. End With
    
27. arr = dic.keys()
    
28. 
    
29. For i = 0 To UBound(arr)
    
30. SQL = "SELECT * FROM `code_toMany$` where [" & HeadName & "]='" & arr(i) & "'"
    
31.     ThisDocument.MailMerge.DataSource.QueryString = SQL
    
32.    
    
33.     With ThisDocument.MailMerge
    
34.         .Destination = wdSendToNewDocument
    
35.         .SuppressBlankLines = True
    
36.         .Execute Pause:=False
    
37.     End With
    
38.    
    
39.     With ActiveDocument
    
40.         .Content.Characters.Last.Previous.Delete '删除新文档最后一个字符
    
41.         For r = .Tables(1).Rows.Count To 2 Step -1
    
42.             'If Len(Application.CleanString(.Tables(1).Rows(i).Cells(1).Range.Text)) = 2 Then
    
43.             If .Tables(1).Rows(r).Cells(1).Range.Text = Chr(13) & Chr(7) Then
    
44.                .Tables(1).Rows(r).Delete
    
45.             Else
    
46.                Exit For
    
47.             End If
    
48.         Next
    
49.         .SaveAs FileName:=MyPath & "" & arr(i) & ".docx"
    
50.         .Close
    
51.     End With
    
52. Next
    
53. ThisDocument.MailMerge.DataSource.Close
    
54. Application.ScreenUpdating = True
    
55. MsgBox ("Very Good!!!")
    
56. End Sub

复制代码

wdpfox

想学习，有附件样本就更好了。请上附件。

灵犀之声

wdpfox 发表于 2023-10-11 20:38
想学习，有附件样本就更好了。请上附件。

邮件合并只能是照着步骤模拟，不太好上传附件

灵犀之声

wangqh8203 发表于 2023-10-11 13:51
我是用纯代码来解决一对多的数据合并。
第一：辅助列最后会有很多空行，表格不美观。
第二：后期还需要 ...

厉害，相互学习

乐铁松

电子邮件的功能，的确太强大。向你们学习了！

shenjianrong163

按照楼上的步骤没有成功！
能否将“（4）按Alt+F9切换到域代码，在图片路径后面输入两个\\，执行插入合并域，选择照片”这一步骤的域代码弄个截图吗？