Find and copy paragraphs from Word

I have a word document with a list of questions that are numbered
e.g.

1. Question 1
   Question 1 stuff....
   some question 1 pictures

2. Question 2
   Quest 2 stuff....

etc

I'm trying to write an excel program that will open the word document and copy the various questions and their images.

My code so far is:

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set objDoc = objWord.Documents.Open("MyFileName")

Set objRange = objDoc.Range

objRange.Copy

shquestions.Range("A1").PasteSpecial
        
objWord.Quit SaveChanges:=False
Set objWord = Nothing

Which works fine at copying the entire word document, and pasting it exactly how I want (as an image, with the images from word document included)

However I can't work out how to get the code to select question 1 and copy and paste it, then question 2 and copy and paste it.

Questions are always numbered so I can use that to identify the next question, but I don't know how to set my objRange to a specific area in the word document

This is a sample of how the word document looks (I took out the questions text, as doesn't belong to me so I can't really share)

What I was hoping was that I could define the range based on the numbering (so copy from the top to the line just before number 2. etc

But so far all I can figure out is how to define the first and last range

objDoc.Paragraphs.First.Range
objDoc.Paragraphs.Last.Range

You can access the list elements in a word document with ListParagraphs. So the most basic code would be

With ThisDocument
    .Range.ListParagraphs(1).Range.Copy
    ' (Do whatever you want to do now)
End With

Or, as Loop:

Dim i As Long
For i = 1 to .Range.ListParagraphs(i).Count
    .Range.ListParagraphs(i).Range.Copy
    ' (Again: Do whatever you want to do now)
Next

Now, this has 2 issues:

(1) That would only copy the paragraph that is numbered. Your data looks as if there are many paragraphs per question, so we have to look for the begin of the next question.

(2) ListParagraphs lists all paragraphs that contain numbering. If your question 1 contains sublists (1.1, 1.2...), those sublist paragraphs would also be within the ListParagraphs collection.

The following function will search for a List number on a certain level and return the range containing all text until the paragraph with the next number.

Function GetListRange(doc As Document, listLevel As Long, listValue As Variant) As Range
    Dim rStart As Range, rEnd As Range, i As Long
    For i = 1 To doc.ListParagraphs.Count
        Dim p As Paragraph
        Set p = doc.ListParagraphs(i)
        With p.Range.ListFormat
            If .ListLevelNumber = listLevel And .listValue = listValue Then
                Set rStart = p.Range
            End If
            
            If Not rStart Is Nothing _
            And ((.ListLevelNumber = listLevel And .listValue > listValue) _
             Or .ListLevelNumber < listLevel) Then
                Set rEnd = p.Range
                Exit For
            End If
        End With
    Next i

    If rStart Is Nothing Then Exit Function   ' ListValue not present
    
    If rEnd Is Nothing Then ' Last entry in List, copy till the end of document
        Set GetListRange = doc.Range(rStart.Start, doc.Range.End)
    Else
        Set GetListRange = doc.Range(rStart.Start, rEnd.Start)
    End If
End Function

Now you can loop over all "questions" with

Dim questionNr as Long, questionRange as Range
questionNr = 0
Do While True
    questionNr = questionNr + 1
    Set questionRange = GetListRange(ActiveDocument, 1, questionNr)
    If questionRange Is Nothing Then Exit Loop

    questionRange.Copy
    ' (...)
Loop

Please, try the next function. It assumes that between two consecutive paragraphs starting with "Question #" other paragraphs (the blah, blah part) which must be copied and the picture staying on the respective range, too. Take care to use your real document full name in the used Constant:

Sub CopyQuestionsfromFromWord(Q1 As String, Q2 As String, Optional boolLast As Boolean = False)
 Dim objWord As Word.Application, objDoc As Word.Document, objRange As Word.Range
 Dim rng1 As Word.Range, rng2 As Word.Range
 Dim shquestions As Worksheet, lastR As Long
 
 Set shquestions = ActiveSheet 'use here the sheet you need
 lastR = shquestions.Range("A" & shquestions.rows.count).End(xlUp).row + 2
 
 Const MyFileName As String = "C:\Teste VBA Excel\Word VBA\Test Word VBA.docm"
 
 On Error Resume Next
  Set objWord = GetObject(, "Word.Application") 'it finds the Word open session
  Set objDoc = objWord.Documents("Test Word VBA.docm")
  If objWord Is Nothing Then
    Set objWord = CreateObject("Word.Application") 'if not found open a new one
    Set objDoc = objWord.Documents.Open(MyFileName)
  End If
 On Error Resume Next: err.Clear
 
 objWord.Visible = True
 
 Set objRange = objDoc.content
 With objRange
    With .Find
        .text = Q1
        If .Execute Then
            Set rng1 = objRange.Paragraphs(1).Range 'the found first paragraph range
        End If
    End With
 End With
 
 Set objRange = objDoc.content
 If Q2 <> "" Then
    With objRange
       With .Find
           .text = Q2
            If .Execute Then
               Set rng2 = objRange.Paragraphs(1).Range 'the second question paragraph range
           End If
       End With
    End With
 Else
   Set rng2 = objDoc.Range
 End If
 'extend the first found paragraph range, up to the next question:
  rng1.SetRange start:=rng1.start, End:=IIf(Q2 <> "", rng2.start, rng2.End)
  rng1.Copy
  
  shquestions.Range("A" & lastR).Select
  shquestions.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:=False
 
 If boolLast Then
    If Not Q2 = "" Then
        CopyQuestionsfromFromWord Q2, "", True
    Else
        objDoc.Close SaveChanges:=False
        objWord.Quit
        MsgBox "Ready..."
    End If
 End If
End Sub

It can be used in the next way. You should only write in nrQ constant the Questions interval:

Sub testCopyQuestionsfromFromWord()
  Dim nrQ As String: nrQ = "1:10" 'here questions from 1 to 10
  Dim arrQ: arrQ = Application.Evaluate("Transpose(Row(" & nrQ & "))")
  arrQ = Split("Question " & Join(arrQ, "|Question "), "|")
  Dim i As Long
  For i = 0 To UBound(arrQ) - 1
    If i = UBound(arrQ) - 1 Then
        CopyQuestionsfromFromWord CStr(arrQ(i)), CStr(arrQ(i + 1)), True
    Else
        CopyQuestionsfromFromWord CStr(arrQ(i)), CStr(arrQ(i + 1))
    End If
  Next i
End Sub

Please, send some feedback after testing it.

Now, the above solution, after the last question found, it return from that paragraph to the end of the file, assuming that nothin else exist after this last question. But, if it exists, you should place a kind of marker, let us say "End of Questions" after the last one and I will adapt the code to return up to it...