如何将标签之间的文本从 excel vba 移动到新文档词

Question

我有一长串 word 文档，它们都有三页。现在我想要文档 1 中的每个第一页，文档 2 中的每个第 2 页和文档 3 中的每个第 3 页。我的 word 文档中的每一页都有标签，但每一页都有相同的标签。我需要搜索标签，select 标签以及介于两者之间的所有内容，并将它们移动到新文档中。然后，再次搜索找到第二个标签（与第一个标签相同的文本）并执行相同的操作。

我有一个 excel sheet 和 filenames/locations 所有带标签的文档，所以我 运行 所有这些都来自 excel vba.

我已经尝试 find/select 代码，但它 select 是第一个和最后一个标签，而不是第一个。你能帮帮我吗？

这是我目前一个一个打开word文档并查找标签的代码：

Sub SelectRangeBetween()

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

Dim wrdApp As Word.Application
' Set wrdApp = CreateObject("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
        With .ActiveDocument.Content.Duplicate
         .Find.Execute Findtext:=startTag & "*" & endTag, MatchWildcards:=False, Forward:=False
         .MoveStart wdCharacter, Len(startTag)
         .MoveEnd wdCharacter, -Len(endTag) - 1
         .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

试试这个：

Private Sub Combine()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")                  'Change to the correct sheetname
    
    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
            
    Dim wrdApp As Word.Application
    Set wrdApp = New Word.Application
    wrdApp.Visible = True
    Dim page1Doc As Word.Document
    Set page1Doc = wrdApp.Documents.Add
    
    Dim page2Doc As Word.Document
    Set page2Doc = wrdApp.Documents.Add
    
    Dim page3Doc As Word.Document
    Set page3Doc = wrdApp.Documents.Add
    
    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 endTag As String
                endTag = ws.Cells(i, EndtagColumn).Value2
                        
                Dim extractDoc As Word.Document
                Set extractDoc = wrdApp.Documents.Open(wrdPath)
                
                'Find first endtag
                Dim page1Rng As Word.Range
                Set page1Rng = extractDoc.Range.Duplicate
                With page1Rng.Find
                    .Text = endTag
                    .Execute
                End With
                                
                If page1Rng.Find.Found Then
                    page1Rng.SetRange 0, page1Rng.End + 1
                    page1Rng.Cut
                    page1Doc.Paragraphs.Last.Range.Paste
                    
                    Set page1Rng = Nothing
                    
                    'If success, find second endtag
                    Dim page2Rng As Word.Range
                    Set page2Rng = extractDoc.Range.Duplicate
                    
                    With page2Rng.Find
                        .Text = endTag
                        .Execute
                    End With
                    
                    If page2Rng.Find.Found Then
                        page2Rng.SetRange 0, page2Rng.End + 1
                        page2Rng.Cut
                        page2Doc.Paragraphs.Last.Range.Paste
                              
                        Set page2Rng = Nothing
                              
                        'If success, yolo and cut the rest since it should left with 3rd page
                        extractDoc.Range.Cut
                        page3Doc.Paragraphs.Last.Range.Paste
                        
                        Dim breakRng As Word.Range
                        Set breakRng =  page3Doc.Paragraphs.Last.Range.DuplicateWith page3Doc.Paragraphs.Last.Range.Duplicate
                        .Collapse                                     
                        .InsertBreak  
                        End With
                    End If
                End If
                
                extractDoc.Close 0
            End If
        End If
    Next i
    
    Set extractDoc = Nothing
    Set page1Doc = Nothing
    Set page2Doc = Nothing
    Set page3Doc = Nothing
    Set ws = Nothing
    
    MsgBox "Done!"
End Sub