20170609批量生成WORD合同

Sub NextSeven_CodeFrame()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"


    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Const HEAD_ROW As Long = 1
    Const SHEET_NAME As String = "明细表"
    Const START_COLUMN As String = "A"
    Const END_COLUMN As String = "I"

    Dim Count As Long

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(SHEET_NAME)
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 4).End(xlUp).Row
        Set Rng = .Range(.Cells(HEAD_ROW + 1, START_COLUMN), .Cells(EndRow, END_COLUMN))
        Arr = Rng.Value
    End With


    Dim ModelFolder As String
    Dim FileName As String
    Dim FilePath As String
    Dim NewName As String
    Dim NewFolder As String
    Dim NewPath As String
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    '绑定
    Dim wdApp As Word.Application
    Dim OpenDoc As Word.Document
    Set wdApp = New Word.Application
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


    Dim FindText As String
    Dim RepText As String

    ModelFolder = Wb.Path & "模板"
    NewFolder = Wb.Path & "生成"


  
    For i = LBound(Arr) To UBound(Arr)
        
        '##########################################
        If i > 5 Then GoTo Here   '控制输出几份，注释掉则不限制数量
        '########################################
        '>>>>>>>>>>>>>>>>>诉前财产保全申请书.docx
        FileName = "诉前财产保全申请书.docx"
        FilePath = ModelFolder & FileName
        NewName = i & "-" & Arr(i, 2) & Arr(i, 3) & Arr(i, 4) & "-" & FileName
        NewPath = NewFolder & NewName
        '预先清除文件
        On Error Resume Next
        Kill NewPath
        On Error GoTo 0
        Set OpenDoc = wdApp.Documents.Open(FilePath)
        With OpenDoc

            '逐个信息替换
            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "姓名"
                .Replacement.Text = Arr(i, 2)
                .Execute Replace:=wdReplaceAll
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "身份证"
                .Replacement.Text = Arr(i, 3)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "性别"
                .Replacement.Text = Arr(i, 4)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "出生日期"
                .Replacement.Text = Arr(i, 5)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "机构名称"
                .Replacement.Text = Arr(i, 9)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "账户号"
                .Replacement.Text = Arr(i, 7)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "冻结金额"
                .Replacement.Text = Arr(i, 8)
                .Execute Replace:=wdReplaceOne
            End With

            With .Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = "合同日期"
                .Replacement.Text = Arr(i, 6)
                .Execute Replace:=wdReplaceOne
            End With


            '>>>>>>>>>>>>>>>>>>>>>>>>>
            .SaveAs NewPath
            .Close True
        End With

    Next i

Here:
    wdApp.Quit


    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "Excel Studio"

ErrorExit:
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    Set wdApp = Nothing


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "Excel Studio"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub