Word中3秒创建合同模板

一 、打开Microsoft Word软件，按下组合键(Alt+F11)打开Microsoft Visual Basic窗口，选中"ThisDocument"右键→“查看代码”打开代码编辑器，如下图所示：

二 、复制以下代码，粘贴到代码编辑器中：

Sub 创建合同模板()
Dim strArray As Variant
  strArray = Array("合同模板", "买  方：", "卖  方：", "签订地点：", "签订时间：", "买卖双方本着互信互利原则，……，订立以下合同", "序号", "名称", "型号", "单位", "数量", "单价", "总价", "备注", "单位地址：", "法定代表人：", "委托代表人：", "电  话：", "传  真：", "邮  箱：", "开户银行：", "账  号：", "税  号：")

    Set NewTable = ActiveDocument.Tables.Add(Selection.Range, 21, 8) '创建21行8列表格
    With NewTable
        .Style = "网格型"
        .Cell(1, 1).Merge .Cell(1, 8) '合并第1行1-8个格
        .Cell(1, 1).Range.Text = strArray(0)
        .Cell(1, 1).Height = 30 '单位磅（1磅=0.03527厘米）
        .Cell(1, 1).Range.Font.Size = 16 '单位磅
        .Cell(1, 1).Range.Font.Name = "黑体"
        .Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '水平居中
        .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '垂直居中
        For i = 2 To 3
            ActiveDocument.Range(.Cell(i, 1).Range.Start, .Cell(i, 6).Range.End).Cells.Merge '合并第i行1-6个格
            .Cell(i, 1).Range.Text = strArray(i - 1)
            ActiveDocument.Range(.Cell(i, 2).Range.Start, .Cell(i, 3).Range.End).Cells.Merge
            .Cell(i, 2).Range.Text = strArray(i + 1)
        Next i
        .Cell(4, 1).Merge .Cell(4, 8)
        .Cell(4, 1).Range.Text = strArray(5)
        For i = 1 To 8
            .Cell(5, i).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Cell(5, i).Range.Text = strArray(i + 5)
        Next i
        .Cell(10, 1).Merge .Cell(10, 2)
        .Cell(10, 2).Merge .Cell(10, 7)
        .Cell(10, 1).Range.Text = "合计金额"
        .Cell(11, 1).Merge .Cell(11, 8)
        .Cell(11, 1).Range.Text = "合同约定"
        .Cell(11, 1).Height = 300
        For i = 12 To 21
            ActiveDocument.Range(.Cell(i, 1).Range.Start, .Cell(i, 4).Range.End).Cells.Merge
            .Cell(i, 1).Range.Text = strArray(i + 1)
            ActiveDocument.Range(.Cell(i, 2).Range.Start, .Cell(i, 5).Range.End).Cells.Merge
            .Cell(i, 2).Range.Text = strArray(i + 1)
        Next i
        .Cell(12, 1).Range.Text = strArray(1)
        .Cell(12, 2).Range.Text = strArray(2)
    End With
    MsgBox ("创建完成")
End Sub

二 、按下F5键执行代码，效果图如下：