用word邮件合并并且产生独立word文件+word_table明细+excle产生word单个
附件中是可以直接用excel生成一个个word。但是，有问题问题就是数据太多，一次性生成word很慢.建议数据多一次性生成word，用邮件套打，如果后面想单条生成，就用这个excel生成单条
把这个 模板（库存表达excel模板不是邮件格式.doc）的宏去掉（把»替换成鱻或者其他，把前面这个«替换位空，因为有这个字体替换会有问题）
现场调查的时候，手写一般是word格式，但是最终统计就是excle（数据规范）
做调查要记住
1、有编号，用编号查询很方便，最好是序号001-100，这样一看就知道缺了哪些
2、有记录今天谁交了多少，明天谁交了多少，时间长了就很乱，写下了（纸质很重要）
核心VBA代码在下面
Function excle2doc(strSheet1, strSheet2, wordtemplet, savepath, beginline, lastline, isshow, wordtableno, addname)
Dim wordobj As New Word.Application, selfpath, outpath_name, i, j, m, li, cl, arr, tt
Dim strsheet, wordte
Dim str1, Str2
selfpath = ThisWorkbook.Path
判断 = 0
t = ThisWorkbook.Path
Set fso = CreateObject("scripting.filesystemobject")
If (fso.folderexists(t & "\" & savepath)) Then
'如果存在不管他
' MsgBox "拆分操作没有完成!" & vbCrLf & "请到本目录下“拆分后文档”文件夹查看！！", vbInformation
' Exit Sub
Else
Set f1 = fso.createfolder(t & "\" & savepath)
End If
'以上创建文件夹，多谢Mn860429卡卡西
savepath = ThisWorkbook.Path & "\" & savepath
For i = beginline To lastline
outpath_name = savepath & "\" & Sheets(strSheet1).Cells(i, 1) & "_" & Sheets(strSheet1).Cells(i, 2) & "_" & Right(Sheets(strSheet1).Cells(i, 3), 1) + addname & ".doc"
FileCopy selfpath & "\" & wordtemplet & ".doc", outpath_name
With wordobj
.Documents.Open outpath_name
.Visible = False
For j = 1 To 5 '填写文字数据
str1 = Sheets(strSheet1).Cells(2, j)
Str2 = Sheets(strSheet1).Cells(i, j)
'
' For m = 1 To 20 '替换20次应该够了
' .Selection.HomeKey Unit:=wdStory '光标置于文件首
' If .Selection.Find.Execute(Str1) Then '查找到指定字符串
' .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
' .Selection.Text = Str2 '替换字符串
' Else
' Exit For
' End If
' Next m
' Next j
If str1 = "" Then
Else
wordobj.Selection.Find.ClearFormatting
wordobj.Selection.Find.Replacement.ClearFormatting
With wordobj.Selection.Find
.Text = str1
.Replacement.Text = Str2
.Replacement.Font.Color = wdColorAutomatic
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wordobj.Selection.Find.Execute Replace:=wdReplaceAll
End If
Next j
'
li = 0
' tt = MsgBox(CStr(Sheets(strSheet1).Cells(i, 1)) & Sheets(strSheet2).Cells(2, 1), 0 + 48 + 256 + 0, "提示：")
On Error Resume Next
li = Application.WorksheetFunction.Match(CStr(Sheets(strSheet1).Cells(i, 1)), Sheets(strSheet2).Columns(1), 0)
On Error Resume Next
cl = CInt(Sheets(strSheet2).Cells(li, 7))
' tt = MsgBox(CStr(cl), 0 + 48 + 256 + 0, "提示：")
If Err = 0 Then
arr = Sheets(strSheet2).Cells(li, 2).Resize(cl, 5)
End If
If li > 0 Then
For n = 0 To cl - 1
For m = 1 To 5
.ActiveDocument.Tables(wordtableno).Cell(9 + n, 1 + m).Range = arr(1 + n, m)
Next m
Next n
End If
' For j = 1 To 3 '填写表格数据
' .ActiveDocument.Tables(1).Cell(2, j).Range = Sheets(strsheet1).Cells(i, j + 6)
' .ActiveDocument.Tables(1).Cell(4, j).Range = Sheets(strsheet1).Cells(i, j + 9)
' Next j
' .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
' Str1 = "数据006"
' Str2 = Sheets("数据2").Cells(2, 2)
' .Selection.HomeKey Unit:=wdStory '光标置于文件首
' If .Selection.Find.Execute(Str1) Then '查找到指定字符串
' .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
' .Selection.Text = Str2 '替换字符串
' End If
' .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter '设置位置在页脚
' Str1 = "数据007"
' Str2 = Sheets("数据2").Cells(2, 1)
' .Selection.HomeKey Unit:=wdStory '光标置于文件首
' If .Selection.Find.Execute(Str1) Then '查找到指定字符串
' .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
' .Selection.Text = Str2 '替换字符串
' End If
End With
wordobj.Documents.Save
If isshow Then
wordobj.Visible = True
Exit Function
Else
wordobj.Quit
Set wordobj = Nothing
End If
Next i
If 判断 = 0 Then
i = MsgBox("已输出到 Word 文件！", 0 + 48 + 256 + 0, "提示：")
End If
End Function
