如何使用 Word2010 批量制作客户邀请函

Question

如题所述

Answer 1

这个需要用vba编程来完成。
具体代码需要根据实际情况来定制。
下面给出一段类似的代码（根据excel表格自动批量生成承租合同），仅供参考！
Sub SCWJ()

Dim arr(1 To 1000, 1 To 19) '1-编号 2-类型 3-区域 4-单元 5-楼层 6-面积 7-空房 8-起租日期 9-到期日期 10-周期 11-续费日期 12-续费类别 13-空白 14-空白 15-租金
'16-押金 17-姓名 18-电话 19-sfzhm
hh = 3
jls = 0
With Sheets("电子信息登记档案")
Do While .Cells(hh, 1) <> ""
jls = jls + 1
For j = 1 To 19
arr(jls, j) = .Cells(hh, j)
Next j
hh = hh + 1
Loop
End With

Dim bh As String '编号
Dim lx As String '类型
Dim qy As String '区域
Dim dy As String '单元
Dim lc As String '楼层
Dim mj As String '面积
Dim qzrq As Date '起租日期
Dim dqrq As Date '到期日期
Dim zq As String '周期
Dim xflb As String '续费类别
Dim zj As Long '租金
Dim yj As Long '押金
Dim xm As String
Dim dh As String
Dim sfzhm As String

For i = 1 To jls
bh = arr(i, 1)
lx = arr(i, 2)
qy = arr(i, 3)
dy = arr(i, 4)
lc = arr(i, 5)
mj = arr(i, 6)
qzrq = arr(i, 8)
dqrq = arr(i, 9)
zq = arr(i, 10)
xflb = arr(i, 12)
zj = Val(arr(i, 15))
yj = arr(i, 16)
xm = arr(i, 17)
dh = arr(i, 18)
sfzhm = arr(i, 19)
Select Case lx
Case "市场", "优惠"
Call 替换文本_市场(bh, lx, qy, dy, lc, mj, qzrq, dqrq, zq, xflb, zj, yj, xm, dh, sfzhm)
Case "5å¹´"
Call 替换文本_5年(bh, lx, qy, dy, lc, mj, qzrq, dqrq, zq, xflb, zj, yj, xm, dh, sfzhm)

End Select

Next i
End Sub
Private Sub 替换文本_市场(bh, lx, qy, dy, lc, mj, qzrq, dqrq, zq, xflb, zj, yj, xm, dh, sfzhm)
Dim 当前路径, 导出文件名, 导出路径文件名 As String
Dim Str1, Str2
Dim tarr(1 To 27, 1 To 2)
当前路径 = ThisWorkbook.Path
导出文件名 = bh & ".doc"
导出文件名2 = bh & ".xlsx"
FileCopy 当前路径 & "\模板\房屋租赁合同.doc", 当前路径 & "\待打印WORD文档\" & 导出文件名
FileCopy 当前路径 & "\模板\承租申请.xlsx", 当前路径 & "\待打印WORD文档\" & 导出文件名2
With Sheets("关键字")
For i = 1 To 27
tarr(i, 1) = .Cells(i + 1, 1)

Next i
End With
tarr(1, 2) = xm
tarr(2, 2) = qy
tarr(3, 2) = dy
tarr(4, 2) = lc
tarr(5, 2) = dh
tarr(6, 2) = sfzhm
tarr(7, 2) = mj
tarr(8, 2) = yj
tarr(9, 2) = Num2Money(yj * 12) '大写总租金

tarr(10, 2) = yj * 12 '小写总租金
Select Case xflb
Case "å¹´"
tarr(11, 2) = 1
tarr(12, 2) = 12
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = "" '续费日期2
tarr(16, 2) = "" '续费日期3
tarr(17, 2) = "" '续费日期4
tarr(18, 2) = 12 '第一次几个月租金
tarr(19, 2) = "/"
tarr(20, 2) = "/"
tarr(21, 2) = "/"
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = "/" '大写第二次租金
tarr(24, 2) = "/" '大写第三次租金
tarr(25, 2) = "/" '大写第四次租金
Case "半年"
tarr(11, 2) = 2
tarr(12, 2) = 6
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = Int(qzrq + 183)
tarr(16, 2) = "" '续费日期3
tarr(17, 2) = "" '续费日期4
tarr(18, 2) = 6 '第一次几个月租金
tarr(19, 2) = 6
tarr(20, 2) = "/"
tarr(21, 2) = "/"
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = Num2Money(zj) '大写第二次租金
tarr(24, 2) = "/" '大写第三次租金
tarr(25, 2) = "/" '大写第四次租金

Case "季度"
tarr(11, 2) = 4
tarr(12, 2) = 3
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = qzrq + Int(365 / 4 + 0.5)
tarr(16, 2) = qzrq + Int(365 / 4 * 2 + 0.5) '续费日期3
tarr(17, 2) = qzrq + Int(365 / 4 * 3 + 0.5) '续费日期4
tarr(18, 2) = 3 '第一次几个月租金
tarr(19, 2) = 3
tarr(20, 2) = 3
tarr(21, 2) = 3
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = Num2Money(zj) '大写第二次租金
tarr(24, 2) = Num2Money(zj) '大写第三次租金
tarr(25, 2) = Num2Money(zj) '大写第四次租金

End Select
tarr(14, 2) = qzrq
tarr(27, 2) = dqrq
If mj = 55 Then
tarr(26, 2) = 3
Else
If mj = 75 Then
tarr(26, 2) = 5
Else
tarr(26, 2) = 6
End If
End If
导出路径文件名 = 当前路径 & "\待打印WORD文档\" & 导出文件名
导出路径文件名2 = 当前路径 & "\待打印WORD文档\" & 导出文件名2
Set wdoc = CreateObject("word.application")
wdoc.Visible = False

With wdoc
.Documents.Open 导出路径文件名
.Visible = True
For i = 1 To 27 '填写文字数据
Str1 = tarr(i, 1)
Str2 = tarr(i, 2)
bj = True
Do While bj
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
'.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
Else
bj = False
End If
Loop
Next i
End With
wdoc.Documents.Save
wdoc.Quit
Set wdoc = Nothing

'写入承租申请
'房号 !区域!单元!楼层
'户型 !面积
'承租说明付款方式: !周期!续费日期!续费

Set myb = Workbooks.Open(导出路径文件名2)
Dim xfrq As Date '续费日期
Select Case xflb
Case "å¹´"
xfrq = dqrq
Case "半年"
xfrq = qzrq + 182
Case "季度"
xfrq = qzrq + 91
End Select
With myb.Sheets("sheet1")
.Cells(3, 2) = xm
.Cells(4, 2) = dh
.Cells(5, 2) = sfzhm
.Cells(6, 2) = qzrq
.Cells(7, 2) = dqrq
.Cells(3, 6) = qy & Space(1) & dy & Space(1) & lc
.Cells(4, 6) = mj
.Cells(5, 6) = yj * 12
.Cells(6, 6) = yj
.Cells(7, 6) = ""
.Cells(9, 1) = zq & " " & xfrq & " " & xflb
End With
myb.Save
myb.Close

End Sub
Private Sub 替换文本_5年(bh, lx, qy, dy, lc, mj, qzrq, dqrq, zq, xflb, zj, yj, xm, dh, sfzhm)
Dim 当前路径, 导出文件名, 导出路径文件名 As String
Dim Str1, Str2
Dim tarr(1 To 20, 1 To 2)
当前路径 = ThisWorkbook.Path
导出文件名 = bh & ".doc"
导出文件名2 = bh & ".xlsx"
FileCopy 当前路径 & "\模板\自装合同模板.doc", 当前路径 & "\待打印WORD文档\" & 导出文件名
FileCopy 当前路径 & "\模板\承租申请.xlsx", 当前路径 & "\待打印WORD文档\" & 导出文件名2
With Sheets("关键字")
For i = 1 To 20
tarr(i, 1) = .Cells(i + 1, 3)

Next i
End With
tarr(1, 2) = xm
tarr(2, 2) = qy
tarr(3, 2) = dy
tarr(4, 2) = lc
tarr(5, 2) = sfzhm
tarr(6, 2) = mj
tarr(7, 2) = qzrq
tarr(8, 2) = dqrq
mzrq = Int(qzrq + 18 * 30.42708333) '免租日期
tarr(9, 2) = mzrq
tarr(10, 2) = zj '小写总租金
tarr(11, 2) = qzrq
tarr(12, 2) = DateSerial(Year(mzrq) + 1, Month(mzrq), Day(mzrq))

tarr(13, 2) = DateSerial(Year(mzrq) + 2, Month(mzrq), Day(mzrq))
tarr(14, 2) = DateSerial(Year(mzrq) + 3, Month(mzrq), Day(mzrq))
tarr(15, 2) = yj

If mj = 55 Then
tarr(16, 2) = 3
Else
If mj = 75 Then
tarr(16, 2) = 5
Else
tarr(16, 2) = 6
End If
End If
tarr(17, 2) = dh
tarr(18, 2) = Num2Money(zj)
tarr(19, 2) = mzrq
tarr(20, 2) = Num2Money(zj / 2)

导出路径文件名 = 当前路径 & "\待打印WORD文档\" & 导出文件名
导出路径文件名2 = 当前路径 & "\待打印WORD文档\" & 导出文件名2
Set wdoc = CreateObject("word.application")
wdoc.Visible = False

With wdoc
.Documents.Open 导出路径文件名
.Visible = True
For i = 1 To 20 '填写文字数据
Str1 = tarr(i, 1)
Str2 = tarr(i, 2)
bj = True
Do While bj
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
'.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
Else
bj = False
End If
Loop
Next i
End With
wdoc.Documents.Save
wdoc.Quit
Set wdoc = Nothing

Set myb = Workbooks.Open(导出路径文件名2)
Dim xfrq As Date '续费日期
Select Case xflb
Case "å¹´"
xfrq = dqrq
Case "半年"
xfrq = qzrq + 182
Case "季度"
xfrq = qzrq + 91
End Select
With myb.Sheets("sheet1")
.Cells(3, 2) = xm
.Cells(4, 2) = dh
.Cells(5, 2) = sfzhm
.Cells(6, 2) = qzrq
.Cells(7, 2) = dqrq
.Cells(3, 6) = qy & Space(1) & dy & Space(1) & lc
.Cells(4, 6) = mj
.Cells(5, 6) = yj * 12
.Cells(6, 6) = yj
.Cells(7, 6) = ""
.Cells(9, 1) = zq & " " & xfrq & " " & xflb
End With
myb.Save
myb.Close

End Sub