The word document contains the following pattern.

$fragment:[optionName]ID_123456$
Cooler machine
$endfragment$

$fragment:[optionDescription]ID_123456$
Regenerative cooler machine with features such as beverage solutions.
$endfragment$

I want to

1. extract from the word document all the option names e.g. “cooler machine”
2. provide the user with a list of all option names e.g. “cooler machine”
3. result must be a word document with only user selected option names with their matching descriptions

Help me to create part 2 and 3 and to improve 1. Below is my solution for part 1.

P.S. One problem is the fragments are inconsistent in the word document. Sometimes they are in the beginning of a paragraph and sometimes several fragments are aggregated into one paragraph.

Private Sub Form_Open()
    Debug.Print "Form Open"
    
    Dim wdDoc As Object
    Set wdDoc = loadDocument("C:UsersxyzDownloadsproduct.docx")
    
    Dim optionsColl As Collection
    Set optionsColl = getFragments(wdDoc, "$fragment:[optionName]", "$endfragment$")
    
    Dim v As Variant
    For Each v In optionsColl
        Debug.Print v & vbCrLf
    Next
    
End Sub

Private Function getFragments(wdDoc As Object, startMark As String, endMark As String) As Collection
    Dim rng As Object
    Dim rng2 As Object
    
    'start position & end position of the fragment
    Dim sp As Long
    Dim ep As Long
    
    Dim fragmentsColl As Collection
    Set fragmentsColl = New Collection
    
    Set rng = wdDoc.content
    
    With rng.Find
        .text = startMark
        .Forward = True
        Do While .Execute
            sp = rng.Start
            'startMark has been saved, now identify the next endMark after search hit in the word document
            Set rng2 = wdDoc.range(sp, wdDoc.content.End)
            
            Do
            
                With rng2.Find
                    .text = endMark
                    .Forward = True
                    If .Execute Then
                        ep = rng2.Start
                        
                        Dim r As Object
                        Set r = wdDoc.range(sp, ep)
                
                        Dim txt As String
                        txt = r.text
                        txt = Right(txt, Len(txt) - Len(startMark))
                        fragmentsColl.Add (txt)
                        
                        Exit Do
                    End If
                End With
            
            Loop
        Loop
    End With
    
    Set getFragments = fragmentsColl
End Function

Thanks in advance!