[已解决]请老师们帮帮忙：vba方式制作类似邮件合并功能

yjwdjfqb

请老师们帮帮忙：vba方式制作类似邮件合并功能

这个也是论坛的老师帮我做的，但今天在用时，有一个家庭成员的地方不会做了，请老师们帮帮我，如图，谢谢老师们了
另外在生成文件时，把所有人员生成到一个WORD文件。

vba方式制作类似邮件合并功能.rar (95.43 KB, 下载次数: 8)

2016-10-12 19:03 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

bajifeng

2016-10-12 20:23

>>>>>>>>>>>>>>>

跳转到最佳答案楼层

bajifeng

1. Sub 生成()    'by bajifeng
   
2. Dim arr, i%, strPath$, br
   
3. arr = Range("A1").CurrentRegion.Value
   
4. Application.DisplayAlerts = False
   
5. 
   
6. strPath = ThisWorkbook.Path & Application.PathSeparator
   
7. Dim objWord As Object
   
8. Set objWord = CreateObject("word.application")
   
9. With objWord
   
10.     For i = 2 To UBound(arr)
    
11. 
    
12.         With .Documents.Add(Template:=strPath & "模板.doc")
    
13.             Application.StatusBar = "正在处理 " & Cells(i, "B")
    
14. 
    
15.             .bookmarks("姓名").Range.Text = Cells(i, "B")
    
16.             .bookmarks("性别").Range.Text = Cells(i, "H")
    
17.             .bookmarks("出生年月").Range.Text = Format(Cells(i, "I"), "yyyy.mm")
    
18.             .bookmarks("年龄").Range.Text = Cells(i, "j")
    
19. 
    
20.             If Len(arr(i, 22)) Then
    
21.                 br = jtcy(arr(i, 22))
    
22.                 For ii = 1 To UBound(br)
    
23.                     For jj = 1 To UBound(br, 2)
    
24.                         With .Tables(2)
    
25.                             .Cell(4 + ii, 1 + jj).Range.Text = br(ii, jj)
    
26.                         End With
    
27.                     Next
    
28.                 Next
    
29.             End If
    
30. 
    
31.             .SaveAs strPath & Cells(i, "B") & ".doc", FileFormat:=0
    
32.             .Close True
    
33.         End With
    
34.     Next
    
35.     .Quit
    
36. End With
    
37. Application.StatusBar = ""
    
38. Application.DisplayAlerts = True
    
39. MsgBox "整理完成", , "提示"
    
40. End Sub
    
41. Function jtcy(ByVal oCell As String) As Variant
    
42. 'by bajifeng
    
43. ar = Split(oCell, Chr(10))
    
44. ReDim br(1 To UBound(ar) + 1, 1 To 5)
    
45. For i = 0 To UBound(ar)
    
46.     tr = Split(ar(i), "，")
    
47.     For j = 0 To UBound(tr)
    
48.         br(i + 1, j + 1) = tr(j)
    
49.     Next
    
50. Next
    
51. jtcy = br
    
52. End Function

复制代码

bajifeng

>>>>>>>>>>>>>>>

yjwdjfqb

bajifeng 发表于 2016-10-12 20:23
>>>>>>>>>>>>>>>

谢谢老师的帮助，这几天有事，今天才看。
非常的好用，感谢老师了！