以下是一位老师做的自动邮件合并代码,可以根据自己需要修改代码
本代码执行,需要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文件。
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
联系客服