Excel明细生成多个word采购合同，Excel魔方完成

场景：

我们的采购信息存储在excel中，需要以合同编号为基准，批量生成多个word采购合同。

采购合同样本如下：

实现方法和步骤：

 通常这种可以使用邮件合并来完成，但是涉及多条信息拆分到word中的时候，邮件合并就不好使了。所以这里，我们用Excel魔方插件来实现。

我们先对word采购合同做一些整理：

模板中，需要替换的字段，这么标识：
Excel中列名是姓名，到Word里面就要改成【姓名】，以此类推。
多条明细内容，需要单独加明细二字：
Excel中列名是规格型号，到Word里面就要改成【规格型号】明细，以此类推。

接着，打开插件按钮

配置好模板路径以及excel明细数据的区域

执行完之后结果如下：

其中用到了excel vba和wordvba的知识。

Sub 写入Word数据()
Application.ScreenUpdating = False
Set doc = CreateObject("word.application")
doc.Visible = True
kehu_row = ActiveSheet.Cells(Rows.Count, 3).End(3).Row '找到C列已使用的最大行号，客户名称所在列
For i = 2 To kehu_row '开始对C列进行循环
If Cells(i, 3) <> "" And Cells(i + 1, 3) = "" Then '当是最后一行的情况的时候
r = Cells(i, 3).End(xlDown).Row - 1 '获取第三列此时的最大行号-1
If r = Rows.Count - 1 And r <> Cells(i, 4).End(xlDown).Row - 1 Then '该客户有多个商品
r = Cells(i, 4).End(xlDown).Row '第四列已使用的最大行号赋值给r
ElseIf r = Rows.Count - 1 And r = Cells(i, 4).End(xlDown).Row - 1 Then '该客户只有一个商品
r = i
End If
Set wd = doc.Documents.Open(ThisWorkbook.Path & "\合同模板.docx")
With doc.Documents(1).Tables(1)
.Rows(2).Select
If r <> i Then doc.Selection.insertrowsbelow r - i '如果r<>i，也就是说，该客户不止一件商品，word表格插入行
For rr = 2 To r - i + 2 '开始往word表格中写入数据
.cell(rr, 1).Range = IIf(Cells(i + rr - 2, 5).Value = "", "", Cells(i + rr - 2, 5).Value)
.cell(rr, 2).Range = IIf(Cells(i + rr - 2, 6).Value = "", "", Cells(i + rr - 2, 6).Value)
.cell(rr, 3).Range = IIf(Cells(i + rr - 2, 7).Value = "", "", Cells(i + rr - 2, 7).Value)
.cell(rr, 4).Range = IIf(Cells(i + rr - 2, 8).Value = "", "", Cells(i + rr - 2, 8).Value)
.cell(rr, 5).Range = IIf(Cells(i + rr - 2, 9).Value = "", "", Cells(i + rr - 2, 9).Value)
.cell(rr, 6).Range = IIf(Cells(i + rr - 2, 10).Value = "", "", Cells(i + rr - 2, 10).Value)
.cell(rr, 7).Range = IIf(Cells(i + rr - 2, 11).Value = "", "", Cells(i + rr - 2, 11).Value)
.cell(rr, 8).Range = IIf(Cells(i + rr - 2, 12).Value = "", "", Cells(i + rr - 2, 12).Value & "％")
Next
.cell(rr, 2).Range = WorksheetFunction.Sum(Range(Cells(i, 8), Cells(r, 8)))
.cell(rr, 5).Range = WorksheetFunction.Sum(Range(Cells(i, 11), Cells(r, 11)))
End With
Set myrange = wd.Content
With doc.Selection '查找替换数据
.HomeKey Unit:=6
.Find.Execute ("日期数据1")
.Text = Cells(i, 1).Value
.HomeKey Unit:=6
.Find.Execute ("日期数据2")
.Text = Cells(i, 1).Value
.HomeKey Unit:=6
.Find.Execute ("需方数据")
.Text = Cells(i, 3).Value
.HomeKey Unit:=6
.Find.Execute ("总金额数据")
.Text = Cells(i, 13).Value
.HomeKey Unit:=6
.Find.Execute ("甲方数据1")
.Text = Cells(i, 3).Value
.HomeKey Unit:=6
.Find.Execute ("甲方数据2")
.Text = Cells(i, 3).Value
End With
doc.ActiveWindow.ActivePane.View.SeekView = 9 '查找替换页眉数据
doc.Selection.HomeKey Unit:=6
If doc.Selection.Find.Execute("合同编号数据") Then
doc.Selection.Text = Cells(i, 2).Value
End If
doc.Selection.Find.Execute Replace:=2
doc.Selection.HomeKey Unit:=6
fpath = ThisWorkbook.Path & "" & Cells(i, 2).Value & "静载合同.docx"
wd.SaveAs fpath
wd.Close False
ElseIf Cells(i, 3) <> "" And Cells(i + 1, 3) <> "" Then '当是中间行的情况的时候
Set wd = doc.Documents.Open(ThisWorkbook.Path & "\合同模板.docx")
With doc.Documents(1).Tables(1)
.cell(2, 1).Range = Cells(i, 5).Value
End With
Set myrange = wd.Content
With doc.Selection
.HomeKey Unit:=6
.Find.Execute ("日期数据1")
.Text = Cells(i, 1).Value
.HomeKey Unit:=6
.Find.Execute ("日期数据2")
.Text = Cells(i, 1).Value
.HomeKey Unit:=6
.Find.Execute ("需方数据")
.Text = Cells(i, 3).Value
.HomeKey Unit:=6
.Find.Execute ("总金额数据")
.Text = Cells(i, 13).Value
.HomeKey Unit:=6
.Find.Execute ("甲方数据1")
.Text = Cells(i, 3).Value
.HomeKey Unit:=6
.Find.Execute ("甲方数据2")
.Text = Cells(i, 3).Value
End With
doc.ActiveWindow.ActivePane.View.SeekView = 9
doc.Selection.HomeKey Unit:=6
If doc.Selection.Find.Execute("合同编号数据") Then
doc.Selection.Text = Cells(i, 2).Value
End If
doc.Selection.Find.Execute Replace:=2
doc.Selection.HomeKey Unit:=6
fpath = ThisWorkbook.Path & "" & Cells(i, 2).Value & "静载合同.docx"
wd.SaveAs fpath
wd.Close False
Else
End If
Next
doc.Quit
Application.ScreenUpdating = True
MsgBox "完成！"
End Sub