如何在 Excel VBA 的 word 文档的每一页上粘贴值？

Question

我在 Excel 中有一长串单词路径以及开始和结束标签。我需要使用 Excel 中指定的路径打开 word 文档，并在每一页的开头粘贴一个开始标签，在每一页的每一端粘贴一个结束标签。每个文件都有三页。 我在 Excel VBA 上苦苦挣扎，似乎无法让它工作。谁能帮帮我？

我需要我的代码遍历列表，打开文件，复制每个页面开头的开始标签，以及每个页面末尾的结束标签，保存并关闭文档并继续下一个文档.

My excel structure

到现在为止，我还是设法打开了我的 excel 文档

Sub startword()
    Set WordApp = CreateObject("word.Application")
    Path = Range("B2").Value & Range("F5").Value
        WordApp.Documents.Open Path
        
        WordApp.Visible = True
End Sub

我能够将值复制并粘贴到新文档中。

Sub copyrange()

    'declare word vars
    Dim WrdApp As Word.Application
    Dim WrdDoc As Word.Document
    'Path = Range("B2").Value & Range("F5").Value
    
    'declare excel vars
    Dim ExcRng As Range
    
    'create new word instance
    Set WrdApp = New Word.Application
        WrdApp.Visible = True
        WrdApp.Activate
        
    Set WrdDoc = WrdApp.Documents.Add
    
    
    
    'create reference to range i want to copy
    Set ExcRng = ActiveSheet.Range("B2:E6")
    
    'copy the range and wait for a bit
    ExcRng.Copy
    Application.Wait Now() + #12:00:01 AM#
    
    'paste the object in word
    WrdDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=False
    
      WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
      
       WrdDoc.Paragraphs(1).Range.PasteSpecial Link:=True, DataType:=wdPasteOLEObject
    
    'clear clipboard
    Application.CutCopyMode = False

End Sub

范围是完全随机的

问题的第二部分 我正在为我的下一段代码而苦苦挣扎。我需要提取第一个开始和结束标签之间的内容（包括标签）并将它们移动到 doc 1，与第 2 页到 doc2、第 3 页到 doc 3 相同。所以我会得到三个文档。 doc1 包含我文档的所有第一页，doc 2 包含所有第二页等。我尝试查找/选择代码，但它选择了第一页和最后一页，而不是第一页。

这是我当前用于一一打开文档的代码：

Sub SelectRangeBetween()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")                  'Change to the correct sheetname

    Dim wrdApp As Word.Application
    Dim WrdDoc As Word.Document
    
    Set wrdApp = New Word.Application                       '
    wrdApp.Visible = True                                   'set to false for higher speed
      
    
    Const StarttagColumn = "C"                              'Edit this for the column of the starttag.
    Const EndtagColumn = "D"                                'Edit this for the column of the endtag.
    Const FilelocationColumn = "E"                          'Edit this for the column of the Filelocation.
    Const startRow As Long = 5                              'This is the first row of tags and filenames
    'Const endRow As Long = 140                             'uncomment if you want a fixed amount of rows (for ranges with empty cells)
    Dim endRow As Long                                      'comment out if const-endrow is used
    endRow = ws.Range("B" & Rows.Count).End(xlUp).Row       'comment out if const-endrow is used

     Dim i As Long
     For i = startRow To endRow
        Dim wrdPath As String
        wrdPath = ws.Cells(i, FilelocationColumn).Value2    '
        
        If wrdPath <> vbNullString Then                     '
            If Dir(wrdPath) <> vbNullString Then            '
                Dim startTag As String                      '
                Dim endTag As String                        '
                
                startTag = ws.Cells(i, StarttagColumn).Value2   '
                endTag = ws.Cells(i, EndtagColumn).Value2       '
                
                Set WrdDoc = wrdApp.Documents.Open(wrdPath) '
            With wrdApp
            '.Documents.Add
            ' .Visible = True
            ' Types the text
            '.Selection.HomeKey Unit:=wdStory
            '.Selection.TypeText Text:="Hello and Goodbye"
            ' The Real script
            'Dim StartWord As String, EndWord As String
            'StartWord = "Hello"
            'EndWord = "Goodbye"
            With .ActiveDocument.Content.Duplicate
             .Find.Execute FindText:=startTag & "*" & endTag, MatchWildcards:=False
             .MoveStart wdCharacter, Len(StardWord)
             .MoveEnd wdCharacter, -Len(EndWord)
             .Select ' Or whatever you want to do
            End With
            
            End With
            With WrdDoc
            .Close
            End With
            End If
        End If
    Next i
End Sub

Answer 1

试试这个版本，我建议你先尝试小批量的文档，因为粘贴标签后文档会立即保存。 （如果您不想保存和/或关闭，请注释掉这些行）：

Option Explicit

Private Sub PasteTagsToDocument()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct name
    
    Const startRow As Long = 5
    Dim endRow As Long
    endRow = ws.Range("B" & Rows.Count).End(xlUp).Row
    
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    
    Set wrdApp = New Word.Application
    wrdApp.Visible = True
                    
    Dim i As Long
    For i = startRow To endRow
        Dim wrdPath As String
        wrdPath = ws.Cells(i, 2).Value2
        
        If wrdPath <> vbNullString Then
            If Dir(wrdPath) <> vbNullString Then
                Dim startTag As String
                Dim endTag As String
                
                startTag = ws.Cells(i, 3).Value2
                endTag = ws.Cells(i, 4).Value2
                
                Set wrdDoc = wrdApp.Documents.Open(wrdPath)
                With wrdDoc
                    .Range(0, 0).InsertBefore startTag & vbNewLine
                    .GoTo(wdGoToPage, wdGoToAbsolute, 2).InsertBefore endTag & vbNewLine & startTag & vbNewLine
                    .GoTo(wdGoToPage, wdGoToAbsolute, 3).InsertBefore endTag & vbNewLine & startTag & vbNewLine
                    .Range.Paragraphs.Last.Range.InsertAfter vbNewLine & endTag
                    
                    .Save 'Comment out if you do not want to save
                    .Close 'Comment out if you do not want to close the document
                End With
            Else
                If MsgBox("File don't exist. " & vbNewLine & wrdPath & vbNewLine & "Click Ok to Continue or Cancel to stop the macro.", vbOKCancel) = vbCancel Then Exit For
            End If
        End If
    Next i
    
    Set ws = Nothing
    
    Set wrdDoc = Nothing
    wrdApp.Quit
    Set wrdApp = Nothing
    
    MsgBox "Complete!"
End Sub