以下是一位老師做的自動(dòng)郵件合并代碼，可以根據(jù)自己需要修改代碼
本代碼執(zhí)行，需要word文檔中有至少一個(gè)2行的表格，出現(xiàn)錯(cuò)誤的代碼省略了
Sub 郵件合并()
Application.ScreenUpdating = False '屏幕刷新關(guān)閉
If ActiveDocument.MailMerge.DataSource.Name <> "" Then ActiveDocument.MailMerge.DataSource.Close '關(guān)閉文件原數(shù)據(jù)源
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "*.xl*"
.AllowMultiSelect = False ' 只允許選取一個(gè)文件
If .Show = -1 Then
myfilepath = .SelectedItems(1)
ActiveDocument.MailMerge.OpenDataSource Name:=myfilepath '執(zhí)行郵件合并
a = ActiveDocument.MailMerge.DataSource.FieldNames.Count '域的個(gè)數(shù)
b = ActiveDocument.Tables.Count '表格的個(gè)數(shù)
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 '屏幕刷新關(guān)閉
End Sub
請(qǐng)老師們幫幫忙：vba方式制作類(lèi)似郵件合并功能
請(qǐng)老師們幫幫忙：vba方式制作類(lèi)似郵件合并功能
這個(gè)也是論壇的老師幫我做的，但今天在用時(shí)，有一個(gè)家庭成員的地方不會(huì)做了，請(qǐng)老師們幫幫我，如圖，謝謝老師們了
另外在生成文件時(shí)，把所有人員生成到一個(gè)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
就是將家庭成員寫(xiě)入到WORD中時(shí)，寫(xiě)入的位置是怎么判斷的。
怎么才能將EXCEL中家庭成員，準(zhǔn)確的寫(xiě)入到WORD文檔的相應(yīng)位置
請(qǐng)老師給我講下好吧，謝謝老師了。
另外，我模板修改了下，老師幫我按這個(gè)模板，修改下代碼，我好對(duì)比下，寫(xiě)入WORD文檔中位置的語(yǔ)句。
'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 = "車(chē)間主任" '第6張表第6行第7列單元格
End With
End Sub
用書(shū)簽的方式大致如下：
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)) '換行符隔開(kāi)的成員信息
r = 1
For Each ra In renArr
rendatarr = Split(ra, "，") '逗號(hào)隔開(kāi)的成員個(gè)人信息
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
