How to move text between tags to new document word from excel vba

Question

I have a long list of word documents which all have three pages. now i want every fist page in document 1, every 2nd page in document 2 and every 3rd page in document 3. I have tags on every page in my word document but every page has the same tag. I need to search for the tags, select the tags and everything in between and move them to the new document. Then, search again to find the 2nd tag (which is the same text as the first one) and do the same thing.

I have an excel sheet with the filenames/locations of all the documents with the tags, so i'm running all this from excel vba.

I've made an attempt to find/select the code, but it selects the first and the last tag, not the first one. Could you help me out?

This is my current code for opening the word docs one by one and finding tags:

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

Try this:

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