|
以下是一位老师做的自动邮件合并代码，可以根据自己需要修改代码
本代码执行，需要word文档中有至少一个2行的表格，出现错误的代码省略了
Sub 邮件合并()
Application.ScreenUpdating = False '屏幕刷新关闭
If ActiveDocument.MailMerge.DataSource.Name <> "" Then ActiveDocument.MailMerge.DataSource.Close '关闭文件原数据源
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "*.xl*"
.AllowMultiSelect = False ' 只允许选取一个文件
If .Show = -1 Then
myfilepath = .SelectedItems(1)
ActiveDocument.MailMerge.OpenDataSource Name:=myfilepath '执行邮件合并
a = ActiveDocument.MailMerge.DataSource.FieldNames.Count '域的个数
b = ActiveDocument.Tables.Count '表格的个数
For j = 1 To b
ActiveDocument.Tables(j).Range.Delete '清空表格
For i = 1 To a
ActiveDocument.Tables(j).Cell(1, i).Range = ActiveDocument.MailMerge.DataSource.FieldNames(i).Name '在表格第1行插入域名
ActiveDocument.MailMerge.Fields.Add Range:=ActiveDocument.Tables(j).Cell(2, i).Range, Name:=ActiveDocument.MailMerge.DataSource.FieldNames(i).Name '在表格第二行插入域
Next i
Next j
'合并到新文档
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument '合并到文档
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
Else
Exit Sub
End If
End With
Application.ScreenUpdating = True '屏幕刷新关闭
End Sub 请老师们帮帮忙：vba方式制作类似邮件合并功能 请老师们帮帮忙：vba方式制作类似邮件合并功能
这个也是论坛的老师帮我做的，但今天在用时，有一个家庭成员的地方不会做了，请老师们帮帮我，如图，谢谢老师们了
另外在生成文件时，把所有人员生成到一个WORD文件。
Sub 生成()
Dim arr, i As Integer
arr = Range("A1").CurrentRegion.Value
Dim strPath$
strPath = ThisWorkbook.Path & Application.PathSeparator
Dim objWord As Object
Set objWord = CreateObject("word.application")
Dim r, c As Integer
Dim renArr
Dim renDatArr
With objWord
For i = 2 To UBound(arr)
With .Documents.Add(Template:=strPath & "模板.doc")
Application.StatusBar = "正在处理 " & Cells(i, "B")
.bookmarks("姓名").Range.Text = Cells(i, "B")
.bookmarks("性别").Range.Text = Cells(i, "H")
.bookmarks("出生年月").Range.Text = Format(Cells(i, "I"), "YYYY.MM")
.bookmarks("年龄").Range.Text = Cells(i, "j")
If Trim(Cells(i, "V")) <> "" Then '如果家庭成员不为空
renArr = Split(Cells(i, "V"), Chr(10))
r = 5
For Each ra In renArr
renDatArr = Split(ra, "，")
c = 2
For Each rd In renDatArr
objWord.activedocument.tables(2).cell(r, c).Range.Text = rd
c = c + 1
Next
r = r + 1
Next
End If
.SaveAs strPath & Cells(i, "B") & ".doc", FileFormat:=0
.Close True
End With
Next
.Quit
End With
Application.StatusBar = ""
MsgBox "整理完成", , "提示"
End Sub
老师你好，谢谢你的帮助，很好用。
就是将家庭成员写入到WORD中时，写入的位置是怎么判断的。
怎么才能将EXCEL中家庭成员，准确的写入到WORD文档的相应位置
请老师给我讲下好吧，谢谢老师了。
另外，我模板修改了下，老师帮我按这个模板，修改下代码，我好对比下，写入WORD文档中位置的语句。
你原来的用的是“隐藏书签”，我觉得更方便，因为修改表格不会影响程序代码，下面这个是直接写单元格方式，如果今后修改了表格，那么同时需要修改代码中的写入位置信息，比较麻烦，代码如下：
'Word演示代码
Sub aa()
Dim Age As Integer
Age = 18
With ActiveDocument.Tables(1)
.Cell(1, 2).Range.Text = "张小小" '第1张表第1行第2列单元格
.Cell(1, 4).Range.Text = "男" '第1张表第1行第4列单元格
.Cell(1, 5).Range.Text = "出生年月(" & Age & "岁)" '第1张表第1行第5列单元格
.Cell(1, 6).Range.Text = "1995.06" '第1张表第1行第6列单元格
.Cell(2, 2).Range.Text = "汉" '第1张表第2行第2列单元格
End With
With ActiveDocument.Tables(6)
.Cell(6, 3).Range.Text = "父亲" '第6张表第6行第3列单元格
.Cell(6, 4).Range.Text = "张三" '第6张表第6行第4列单元格
.Cell(6, 5).Range.Text = "45" '第6张表第6行第5列单元格
.Cell(6, 6).Range.Text = "党员" '第6张表第6行第6列单元格
.Cell(6, 7).Range.Text = "车间主任" '第6张表第6行第7列单元格
End With
End Sub
用书签的方式大致如下：
Sub 生成()
Dim arr, i As Integer
arr = Range("A1").CurrentRegion.Value
Dim strPath$
strPath = ThisWorkbook.Path & Application.PathSeparator
Dim objWord As Object
Dim s As Integer
Set objWord = CreateObject("word.application")
With objWord
For i = 2 To UBound(arr)
With .Documents.Add(Template:=strPath & "模板.doc")
Application.StatusBar = "正在处理 " & Cells(i, "B")
.bookmarks("姓名").Range.Text = Cells(i, "B")
.bookmarks("性别").Range.Text = Cells(i, "H")
.bookmarks("出生年月").Range.Text = Format(Cells(i, "I"), "YYYY.MM")
.bookmarks("年龄").Range.Text = Cells(i, "j")
If Trim(Cells(i, "V")) <> "" Then '如果家庭成员不为空
renArr = Split(Cells(i, "V"), Chr(10)) '换行符隔开的成员信息
r = 1
For Each ra In renArr
rendatarr = Split(ra, "，") '逗号隔开的成员个人信息
For s = 0 To UBound(rendatarr)
objWord.ActiveDocument.bookmarks("成员" & r & s + 1).Range.Text = rendatarr(s)
Next s
r = r + 1
Next
End If
.SaveAs strPath & Cells(i, "B") & ".doc", FileFormat:=0
.Close True
End With
Next
.Quit
End With
Application.StatusBar = ""
MsgBox "整理完成", , "提示"
End Sub
|
