楼主
kevinchengcw |
Q: 如何用vba代码依据模板复制数据到word文档中生成多份报表(类似邮件合并效果)?
A: 实现代码如下：- Sub test()
- Dim Arr, Rule, N&, I&, FN$, Rng As Object
- With Worksheets("病案基本信息表-1")
- Arr = .[a1].Resize(.Cells(.Rows.Count, 1).End(3).Row, .Cells(1, .Columns.Count).End(1).Column).Value '提取信息到数组中
- End With
- FN = ThisWorkbook.Path & "\治疗卡模板_.doc" '设定模板文件路径
- Rule = Array(14, 21, 28, 43, 49, 78, 91, 95, 120, 139, 177, 185, 193, 242, 271) '初始化文本写入位置数据(位置据文本数据头的偏移量,具体数据可以在word中选定指定位置后在vbe立即窗口用?selection.range.start查看)
- If Dir(FN) <> "" Then '如果存在模板文件,则
- With CreateObject("word.application") '创建word进程
- .Visible = True '使进程显示出来,也可以设置为false隐藏执行
- With .Documents.Open(FN) '打开模板文件
- .SaveAs ThisWorkbook.Path & "\治疗卡.doc" '先另存为目标文件
- Set Rng = .Range '设置复制区域为模板全部内容
- Rng.Copy '复制
- '以上两句可以直接写为.range.copy,从而省去Rng变量
- For N = LBound(Arr) + 1 To UBound(Arr) '循环数据区
- .Application.Selection.HomeKey 6 'word中光标位置移动到文件头
- .Application.Selection.Paste '粘贴复制的数据
- For I = UBound(Arr, 2) To LBound(Arr, 2) Step -1 '从后向前循环数据偏移位置(因粘贴在前面,所以当前写入区域相对文本数据头位置固定)
- If I - 1 <= UBound(Rule) Then .Range(Rule(I - 1), Rule(I - 1)).Text = Trim(Arr(N, I)) '在处于有效数据范围时将对应数据写入对应位置
- Next I
- Next N
- Set Rng = Nothing '清空变量
- .Save '保存word文档修改
- .Close '关闭word文档
- End With
- .Quit '退出进程
- End With
- MsgBox "处理完成"
- Else
- MsgBox "未找到模板文件！"
- End If
- End Sub
详细内容见附件及素材源帖。
 excel数据自动写入word模板.rar
|
