我正在尝试在excel中编写一些VBA代码，以自动完成构建100多个.pdf word文档的任务，每个文档都遵循设置的模板。我最初从youtube tutorial复制了一个代码，该代码显示了如何从电子表格构建自动电子邮件，并且我觉得我的应用程序非常相似。
我可以按照需要进行替换。我的主要问题是将图像插入到需要的位置。我尝试使用书签，但没有运气替换代码。我认为我的问题在于我的变量在各个子变量之间没有正确的值，尽管那只是我未受过教育的最佳猜测。
我的下一个问题是创建代码以从现有文档中提取文本并将其粘贴到新文档中。老实说，我在图像问题上一直陷入困境，以至于我什至都没有对此进行研究。
我可能会以一种低效的方式来执行此任务，但是，如果有人可以在我的代码中发现错误，将不胜感激。我在下面粘贴了我现有的代码。希望它还不错。
Option Explicit
Dim CustRow, CustCol, LastRow, TemplRow, j As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp As Object
Dim WordContent As Word.Range
Sub CreateWordDocuments()
With Sheet1
If .Range("B3").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("G3").Value 'Set Template Name
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 8 To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 5 To 10 'Move Through 6 Columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
Call InsertScreenshots
If .Range("I3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("O" & CustRow).Value = TemplName 'Template Name
.Range("P" & CustRow).Value = Now
Next CustRow
End With
End Sub
Sub FillABookmark(bookmarkname As String, imagepath As String)
Dim objWord As Object
Dim objDoc As Object
With Sheet1
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "DocLoc"
End If
Set objDoc = objWord.ActiveDocument
With objDoc
.Bookmarks(bookmarkname).Select
.Shapes.AddPicture FileName:=imagepath
End With
End With
End Sub
Sub InsertScreenshots()
With Sheet1
For CustCol = 11 To 14 'Move Through 4 Columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
Call FillABookmark("TagName", "TagValue")
Next CustCol
End With
End Sub
答案 0 :(得分：1)
这里有很多事情，还有很多问题。
要点
Dim所有变量，否则将为Variants Object Empty的正确测试是IsEmpty GetObject ClassID是 2nd 参数。我需要使用Word.Application.16，您的安装可能会有所不同On Error Resume Next后重新设置错误处理（这可能是在向您隐藏错误）EndUp查找最后使用的行时，请从工作表底部搜索InsertScreenshots代码的调用Select 注意：如果没有工作簿和word文档的样本，我不能确定没有其他问题，您将需要继续调试。
查看带有~~
标记的更改的内联评论重构代码
Option Explicit
Sub CreateWordDocuments()
'~~ Don't use module scoped variables
'~~ declare all variable types, else they are Variants
Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, j As Long
Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
Dim CurDt As Date, LastAppDt As Date
'~~ to make debugging easier, use Early Binding (add reference to Microsoft Word), to get Intellisence help. If you need late binding, change back later
Dim WordDoc As Word.Document, WordApp As Word.Application ' Object
Dim WordContent As Word.Range '~~ this suggests you are already using Early Binding!
With Sheet1 '~~ If you are going to use CodeNames, give the sheet a meaningful name (edit it in the Properties window)
If IsEmpty(.Range("B3").Value) Then '~~ correct test for Empty
MsgBox "Please select a correct template from the drop down list"
.Range("G3").Select '~~ will only work if Sheet1 is active
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("G3").Value 'Set Template Name
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject(, "Word.Application.16") '~~ correct format for Office365 - YMMV
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0 '~~ reset error handling
'Launch a new instance of Word
Set WordApp = New Word.Application ' CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
On Error GoTo 0 '~~ reset error handling
WordApp.Visible = True
LastRow = .Cells(.Rows.Count, 5).End(xlUp).Row '~~ use real last row 'Determine Last Row in Table
For CustRow = 8 To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 5 To 10 'Move Through 6 Columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
For CustCol = 11 To 14 'Move Through 4 Columns ~~ do it here, it's cleaner and easier to reference the Row
TagName = .Cells(7, CustCol).Value '~~ Bookmark Name
TagValue = .Cells(CustRow, CustCol).Value '~~ Image path and name
FillABookmark TagName, TagValue, WordDoc '~~ call to insert each image
Next
If .Range("I3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else '~~ don't need the :
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("O" & CustRow).Value = TemplName 'Template Name
.Range("P" & CustRow).Value = Now
Next CustRow
End With
End Sub
Sub FillABookmark(bookmarkname As String, imagepath As String, objDoc As Word.Document)
'~~ Use passed Parameter for Doc
'~~ Don't need select
objDoc.Bookmarks(bookmarkname).Range _
.InlineShapes.AddPicture FileName:=imagepath
End Sub