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