office应用程序是可以相互访问的，比如可以把excel的数据导出到wordzhong
step1：
首先要引用word工程对象，在excelvba中依次点击 工具——》引用——》microsoft word 11.0 library
如果是2007版本，应该选择12。0
step2：
准备excel数据
step3：
添加模块，写入代码
Sub xxx()
'定义WORD应用程序变量
errExit:
errHandle:
End Sub
运行后见图：
需要把Excel中的数据一一填写到Word文档中，而Excel中的数据很长，并且Word文档中只需填写，其他的地方都不需要改动。手工操作实在让人无法忍受（不过，俺却手动完成了一遍，实在是......）。因为以前没有接触过VBS脚本类的东东，所以俺上网搜索了一下，汗，下面就是我的经历了，实在让人郁闷！
首先就是搜索Word正文和Word文档中的文本框里的文本（感觉好绕口）是不同。这里是我绕弯子绕的最多的了，因为以前从来没有接触过，根据就知道，花了我不下6个小时才了解，郁闷之一。
其次是，遍历文档中的文本框内容进行替换时，会丢失格式，目前还没有找到完美的方法，郁闷之二。
有了这两个郁闷，就已经够我喝一壶了，汗（确实喜欢用这个词）。
我的解决方法就是在需要替换的地方新置一个文本框，里面主上一个替换的字眼用以标注和查找替换用。
然后在遍历替换时，查看文本有没有变动。变动则更新文本内容！这就是我的笨方法，运行OK，事情也完成了，不过代码确实不堪！
为了给自己长个记性，把其他的一些用法用注释了，并没有删除掉。
view plaincopy to clipboardprint?
' 通过Excel表格里的信息
' 使用Word模板批量生成Word文档
'
' Write By IAwen 2010-12-07
infoListXLS="E:HRinfo_Test.xls" '信息列表Excel文件名
wordTemplate="E:HRtemplate.doc" 'Word模块文件名
wordOutputPath="E:HR" 'Word文件输出路径
'打开excel
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(infoListXLS)
objExcel.Visible=true
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'从打开的Excel的第二行开始读取
intRow = 3
'Const wdReplaceAll = 2
'Const wdFindContinue = 1
Const msoTextBox = 17
'开始循环，直到第3列为空时退出循环
Do Until objExcel.Cells(intRow,3).Value = ""
'取得第3列、第4列内容：编号和公司名称
num=objExcel.Cells(intRow,3).Value
company=objExcel.Cells(intRow,4).Value
fileName = wordOutputPath & "HR互动邀请信" & num & ".doc"
FSO.CopyFile wordTemplate, fileName
'打开新做成的Word文档，并将姓名跟性别填入Word文档的表格中
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Open(fileName)
'遍历文档中的所有文本框
For Each sharp In objDoc.Shapes
If sharp.Type=msoTextBox Then
tmpString=sharp.TextFrame.TextRange.Text
newString=Replace(tmpString,"##company##", company)
If tmpString <> newString Then
sharp.TextFrame.TextRange.Text = newString
End If
tmpString=sharp.TextFrame.TextRange.Text
newString=Replace(tmpString,"##number##", num)
If tmpString <> newString Then
sharp.TextFrame.TextRange.Text = newString
End If
End If
Next
'搜索文档正文
'Set objSelection = objWord.Selection
'objSelection.Find.Text = "##company##" '查找的文本
'objSelection.Find.Replacement.Text = company
'objSelection.Find.Forward = True
'objSelection.Find.Wrap = wdFindContinue
'objSelection.Find.Format = False
'objSelection.Find.MatchCase = False
'objSelection.Find.MatchWholeWord = True
'objSelection.Find.MatchWildcards = False
'objSelection.Find.MatchSoundsLike = False
'objSelection.Find.MatchAllWordForms = False
'objSelection.Find.Execute ,,,,,,,,,,wdReplaceAll
'保存文件
objDoc.save()
Set objDoc=Nothing
objWord.Quit
intRow = intRow + 1
Loop
'退出Excel
objExcel.Quit
' 通过Excel表格里的信息
' 使用Word模板批量生成Word文档
'
' Write By IAwen 2010-12-07
infoListXLS="E:HRinfo_Test.xls" '信息列表Excel文件名
wordTemplate="E:HRtemplate.doc" 'Word模块文件名
wordOutputPath="E:HR" 'Word文件输出路径
'打开excel
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(infoListXLS)
objExcel.Visible=true
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'从打开的Excel的第二行开始读取
intRow = 3
'Const wdReplaceAll = 2
'Const wdFindContinue = 1
Const msoTextBox = 17
'开始循环，直到第3列为空时退出循环
Do Until objExcel.Cells(intRow,3).Value = ""
'取得第3列、第4列内容：编号和公司名称
num=objExcel.Cells(intRow,3).Value
company=objExcel.Cells(intRow,4).Value
fileName = wordOutputPath & "HR互动邀请信" & num & ".doc"
FSO.CopyFile wordTemplate, fileName
'打开新做成的Word文档，并将姓名跟性别填入Word文档的表格中
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Open(fileName)
'遍历文档中的所有文本框
For Each sharp In objDoc.Shapes
If sharp.Type=msoTextBox Then
tmpString=sharp.TextFrame.TextRange.Text
newString=Replace(tmpString,"##company##", company)
If tmpString <> newString Then
sharp.TextFrame.TextRange.Text = newString
End If
tmpString=sharp.TextFrame.TextRange.Text
newString=Replace(tmpString,"##number##", num)
If tmpString <> newString Then
sharp.TextFrame.TextRange.Text = newString
End If
End If
Next
'搜索文档正文
'Set objSelection = objWord.Selection
'objSelection.Find.Text = "##company##" '查找的文本
'objSelection.Find.Replacement.Text = company
'objSelection.Find.Forward = True
'objSelection.Find.Wrap = wdFindContinue
'objSelection.Find.Format = False
'objSelection.Find.MatchCase = False
'objSelection.Find.MatchWholeWord = True
'objSelection.Find.MatchWildcards = False
'objSelection.Find.MatchSoundsLike = False
'objSelection.Find.MatchAllWordForms = False
'objSelection.Find.Execute ,,,,,,,,,,wdReplaceAll
'保存文件
objDoc.save()
Set objDoc=Nothing
objWord.Quit
intRow = intRow + 1
Loop
'退出Excel
objExcel.Quit
测试文档与脚本文件下载：
下载文件 (已下载 351 次)
点击这里下载文件: ExcelToWord.rar
转自：IaWeN's Blog-iawen,原创,安全,破解视频,网页设计,影视后期,AE特效
链接：http://www.iawen.com/read.php/362.htm
来自 “ ITPUB博客 ” ，链接：https://blog.itpub.net/7868752/viewspace-1057183/ ，如需转载，请注明出处，否则将追究法律责任。
