我制作了一个excel文件,用户完成操作后,单击一个可生成三个Word文件的按钮,用户应在其中填写一列详细信息。在Excel中,我命名了写入用户详细信息的单元格。在word文件中,我将变量(单元格的名称)放在需要的位置。除了将用户输入的内容替换为word文件中的变量之间的所有内容之外,所有其他事情都运行良好。
Sub createPDF()
Application.ScreenUpdating = False
Dim objWord As Object
Dim ws As Worksheet
Dim theString As String
Dim TemplatePath As String
Dim xWb As Workbook
Dim Pscope As String
'ws.Activate
Set ws = ThisWorkbook.ActiveSheet
Set objWord = CreateObject("Word.Application")
Set xWb = Application.ThisWorkbook
TemplatePath = xWb.Path
objWord.Visible = True
'Target File Extension (must include wildcard "*")
myExtension = "*.doc*"
'Target Path with Ending Extention
myfile = Dir(TemplatePath + "\Template" & "\" & myExtension)
'Loop through each word file in folder
Do While myfile <> ""
objWord.Documents.Open TemplatePath + "\Template" & "\" & myfile 'TemplatePath + "\ProposalTemplate.dotm" ' change as required
With objWord.ActiveDocument.Content.Find
.Text = "company_ename"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("company_ename").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_fname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_pname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_pname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_fullname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fullname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_id1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_id1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_allotted1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_allotted1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
For i = 2 To 4
.Text = "owner_fname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_pname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_pname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_fullname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fullname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_id" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_id" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "owner_allotted" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_allotted" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
Next i
.Text = "house"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("house").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "director_pname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("director_pname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
.Text = "director_fname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("director_fname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll
End With
Dim TheFileName As String
TheFileName = TemplatePath + "\Output\" + ws.Range("company_ename").Value + "_" + Replace(myfile, "docx", "") + ".docx"
'(SaveAs is for Office 2003 and earlier - deprecated)
objWord.ActiveDocument.SaveAs TheFileName
'replaces existing .doc iff exists
' Close Documents and Quit Word
objWord.ActiveDocument.Close savechanges:=False
' objWord.ActiveDocument.Close 'close .DOCx
myfile = Dir
Loop
Set objWord = Nothing
MsgBox "Generation Complete!"
Application.ScreenUpdating = True
End Sub
您有很多重复的代码,这些代码应该放在单独的子目录中。
例如:
Sub createPDF()
Dim objWord As Object, doc As Object
Dim ws As Worksheet
Dim theString As String
Dim TheFileName As String, nm, i As Long
Dim TemplatePath As String, myExtension, myfile
Dim Pscope As String
Set ws = ThisWorkbook.ActiveSheet
TemplatePath = ThisWorkbook.Path
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
myExtension = "*.doc*"
myfile = Dir(TemplatePath + "\Template" & "\" & myExtension)
Do While myfile <> ""
Set doc = objWord.Documents.Open(TemplatePath + "\Template" & "\" & myfile)
For Each nm In Array("company_ename", "owner_fname1", "owner_pname1", _
"owner_fullname1", "owner_id1", "owner_allotted1", _
"house", "director_pname1", "director_fname1")
DoReplace doc, ws, nm
Next nm
For i = 2 To 4
For Each nm In Array("owner_fname", "owner_pname", "owner_fullname", _
"owner_id", "owner_allotted")
DoReplace doc, ws, nm & CStr(i)
Next nm
Next i
TheFileName = TemplatePath & "\Output\" & ws.Range("company_ename").Value & _
"_" & Replace(myfile, "docx", "") & ".docx"
doc.SaveAs TheFileName
doc.Close savechanges:=False
myfile = Dir
Loop
Set objWord = Nothing
MsgBox "Generation Complete!"
End Sub
Sub DoReplace(doc As Object, ws As Worksheet, txt)
With doc.Content.Find
.Text = "{" & txt & "}" 'in the Word doc the tag is enclosed in{}
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range(txt).Value
.wrap = 1 'wdfindcontinue
.Execute Replace:=2 'wdReplaceAll
End With
End Sub