如何用VBA实现将Excel数据依次写入Word模板

ugyun

各位老师：
  我现在有一统计表，现需要将其数据依次输入到Word模板中去，再以书面通知的形式邮寄到每个人手中（分散在全国各地），请问除了用邮件合并以外，用VBA如何完成上述功能？先谢谢老师了

ugyun

哪位老师快来帮帮忙呀？不然完成不了任务了

skyzxh

占个座位，看高手如何完成

ty1014

论坛中好像有这方面的帖子呢,搜查下吧

EH_laoliu

占位，等高手解答。

leroy

如果把模板做到Excel里面，问题就简单了。其实使用Excel还是可以作出Word模板效果的

ke3088

请参考：http://club.excelhome.net/viewth ... p;extra=&page=1

xtanuihazfh

写了一个VBS脚本,但是还没写完,不过你可以参考下代码自己修改,中间录宏做的,因为对WORD不熟,搞的乱七八糟
直接复制代码到你的文件夹中新建txt文档,另存为,后缀txt改为VBS即可(前提是调试完能用)
本来是想打开模板文件替换的,但是不知道什么原因不能完成替换,所以成现在这个样子了,半夜12点,不想再继续下去了,有空再说吧

声明:以下代码只是半成品,仅供参考,不能拿来用,出问题鄙人不负责,哈哈

1. Dim WordApp,FSO
   
2. Dim MyTemplate,MyBook,DataArr,MyDoc
   
3. Dim i,n,MyPath,Arr1,Arr2
   
4. Set FSO=CreateObject("scripting.filesystemobject")
   
5. MyPath = FSO.GetFile(WScript.ScriptFullName).ParentFolder.Path
   
6. If Right(MyPath,1)<>"" Then MyPath=MyPath&""
   
7. Set WordApp=CreateObject("Word.Application")
   
8. Set Mybook=GetObject(MyPath & "统计表.xls")
   
9. If MyBook Is nothing Then MsgBox "找不到数据源表格!",64,"提示" : WScript.Quit
   
10. DataArr= MyBook.sheets(1).usedrange
    
11. MyBook.close False
    
12. Set MyBook=nothing
    
13. Arr1=Array(1,3,4,5,6,7)
    
14. FSO.CreateFolder MyPath & "通知书"
    
15. Set FSO=nothing
    
16. MyPath=MyPath &"通知书"
    
17. WordApp.ScreenUpdating=false
    
18. For i = 2 To 5'UBound(dataarr)                        '<----此处调试完成后需要修改
    
19.         Set MyDoc=WordApp.Documents.Add
    
20.         With MyDoc.ActiveWindow.Selection
    
21.                
    
22.                 .Font.Size=16
    
23.                 .ParagraphFormat.Alignment = wdAlignParagraphRight
    
24.                 .TypeText DataArr(i,1)
    
25.                 .TypeParagraph
    
26.                 .ParagraphFormat.Alignment = wdAlignParagraphCenter
    
27.                 .Font.Color = wdColorRed
    
28.                 .Font.Size = 26
    
29.                 .Font.Bold = wdToggle
    
30.                 .TypeText text="名 流 置 业 有 限 公 司 信 笺"
    
31.                 With MyDoc.Shapes.AddLine(30,300,300,300)
    
32.                         .Height= 3
    
33.                         .Fill.color=vbred
    
34.                 End With
    
35.             .Font.Color = wdColorAutomatic
    
36.             .TypeParagraph
    
37.             .TypeText "补发工资通知书"
    
38.             .TypeParagraph
    
39.             .ParagraphFormat.Alignment = wdAlignParagraphLeft
    
40.                 .Font.Underline = wdUnderlineSingle
    
41.                 .TypeText(" " & DataArr(i,3) &" ")        
    
42.             .Font.Underline = wdUnderlineNone
    
43.             .TypeText text="同志:"
    
44.                 .TypeParagraph
    
45.             .TypeText Text=vbtab & "经上级批准，确定从2008年7月1日起，调整工资标准，按照有关文件规定，依据你的工龄，确定补发2009年7月至" & DataArr(i,4) & "的工资差额共计" & DataArr(i,4) & "元，大写" & DataArr(i,5) & "，已通过" & DataArr(i,6) &"发给你，请注意查收。"
    
46.                 .TypeParagraph
    
47.                 .TypeText Text=vbTab &"特此通知."
    
48.                 .TypeParagraph
    
49.                 .TypeParagraph
    
50.                 .TypeText Text=Space(20)&"单位：（盖章）"
    
51.                 .TypeParagraph
    
52.                 .TypeParagraph
    
53.                 .TypeText Text=Space(20)&"二〇一一年五月二十八日"        
    
54.                
    
55.         End with
    
56.         With MyDoc
    
57.                 .SaveAs MyPath & DataArr(i,1) &".doc"
    
58.                 .close
    
59.         End With
    
60. Next
    
61. MyTemplate.Close False
    
62. Set MyTemplate=Nothing
    
63. WordApp.Quit
    
64. Set WordApp=Nothing
    
65. MsgBox "批量合并通知书操作完成,文件存放在" &vbcrlf & MyPath &"  目录下!",64,"提示"
    
66. WScript.quit
    
67. 
    
68. Er:
    
69. MyTemplate.Close False
    
70. Set MyTemplate=Nothing
    
71. WordApp.ScreenUpdating=true
    
72. WordApp.Quit
    
73. Set WordApp=Nothing
    
74. WScript.Quit

复制代码

[ 本帖最后由 xtanuihazfh 于 2011-6-8 00:08 编辑 ]

qdchyq

http://club.excelhome.net/thread-613739-1-1.html

qdchyq

请见附件！！！！！

[ 本帖最后由 qdchyq 于 2011-6-8 05:46 编辑 ]