使用Excel VBA创建Word文档-插入图像？从第三个文档复制并粘贴文本

我正试图在excel中编写一些VBA代码，以自动完成构建100+个.pdf word文档的任务，每个文档都遵循设置的模板。我最初从youtube上复制了一段代码，展示了如何从电子表格中自动生成电子邮件，我觉得我的应用程序非常相似

我可以让文本替换按其应该的方式进行。我的主要问题是将图像插入需要的位置。我尝试使用书签替换代码，但运气不佳。我认为我的问题在于我的变量在不同的子变量之间没有正确的值，尽管这只是我未受过教育的最佳猜测

我的下一个问题是创建一个代码，从现有文档中提取文本并粘贴到新文档中。老实说，我在形象问题上太执着了，我甚至还没有研究过这个问题

我可能会以一种低效的方式完成这项任务，但是，如果有人能够发现我代码中的错误，我将不胜感激。我已将现有代码粘贴到下面。希望不会太糟糕

    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

选项显式
尺寸CustRow、CustCol、LastRow、TemplRow、j等长
Dim DocLoc、标记名、标记值、模板名、文件名为字符串
Dim CurDt，LastAppDt作为日期
Dim WordDoc，WordApp作为对象
将Word内容设置为Word.Range
子CreateWordDocuments（）
附页1
如果.Range（“B3”）.Value=空，则
MsgBox“请从下拉列表中选择正确的模板”
.范围（“G3”）。选择
出口接头
如果结束
TemplRow=.Range（“B3”）.Value“设置模板行”
TemplName=.Range（“G3”）.Value“设置模板名称”
DocLoc=Sheet2.Range（“F”&TemplRow.Value”Word文档文件名
'打开Word模板
“如果Word已在运行，则在出现错误时继续下一步”
Set WordApp=GetObject（“Word.Application”）
如果错误号为0，则
'启动Word的新实例
呃，明白了
'在发生错误时转到错误\u处理程序
设置WordApp=CreateObject（“Word.Application”）
WordApp.Visible=True“使应用程序对用户可见”
如果结束
LastRow=.Range（“E9999”）.End（xlUp）.Row'确定表中的最后一行
对于CustRow=8到LastRow
设置WordDoc=WordApp.Documents.Open（文件名：=DocLoc，只读：=False）打开模板
对于CustCol=5至10’，移动6列
标记名=.Cells（7，CustCol）.Value'标记名
TagValue=.Cells（CustRow，CustCol）.Value'标记值
使用WordDoc.Content.Find
.Text=标记名
.Replacement.Text=标记值
.Wrap=wdFindContinue
.Execute Replace:=wdReplaceAll'查找并替换所有实例
以
下一个卡斯特科尔
调用插入屏幕截图
如果.Range（“I3”）.Value=“PDF”，则
FileName=ThisWorkbook.Path&“\”和.Range（“E”和CustRow）.Value&“\”和.Range（“G”和CustRow）.Value&“.pdf”使用当前工作簿位置、类别和模型创建完整的文件名和路径
WordDoc.ExportAsFixedFormat输出文件名：=文件名，ExportFormat:=wdExportFormatPDF
关闭错误
否则：'如果字
FileName=ThisWorkbook.Path&“\”和.Range（“E”和CustRow）.Value&“\”和.Range（“G”和CustRow）.Value&“.docx”
WordDoc.SaveAs文件名
如果结束
.Range（“O”&CustRow）.Value=TemplName“模板名称”
.Range（“P”和CustRow）.Value=Now
下一个卡斯特罗
以
端接头
子FillABookmark（书签名称为字符串，图像路径为字符串）
Dim objWord作为对象
作为对象的Dim objDoc
附页1
出错时继续下一步
Set objWord=GetObject（，“Word.Application”）
如果objWord什么都不是，那么
设置objWord=CreateObject（“Word.Application”）
objWord.Visible=True
objWord.Documents.Open“DocLoc”
如果结束
设置objDoc=objWord.ActiveDocument
使用objDoc
.书签（书签名称）。选择
.Shapes.AddPicture文件名：=图像路径
以
以
端接头
子插入屏幕截图（）
附页1
对于CustCol=11至14'，通过4列移动
标记名=.Cells（7，CustCol）.Value'标记名
TagValue=.Cells（CustRow，CustCol）.Value'标记值
调用FillABookmark（“标记名”、“标记值”）
下一个卡斯特科尔
以
端接头

这里发生了很多事情，也有很多问题

要点

学习正确缩进的价值

Dim

所有变量，否则它们将是

变量

早期绑定更容易调试。使用显式类型而不是

对象

除非有充分的理由，否则不要使用模块作用域变量

代码名可能很有用，但请给它们指定有意义的名称

Empty

的正确测试为

IsEmpty

GetObject

ClassID是第二个参数。我需要使用

Word.Application.16

，您的安装可能会有所不同

在使用“错误恢复下一步”后，请尽快重置错误处理（这可能是对您隐藏错误）

使用

EndUp

查找最后使用的行时，请从工作表底部搜索

简化了

插入屏幕截图的调用

你已经有一个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