Hi again ecalid. Apparently, I was making this too difficult for your purposes. No need for the collection and using Word's built in page information seems suffice for your application.
Here's the userform code alterations and addition...
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)    
Dim wdApp As Object
    Dim wdDoc As Object
    
    ' Create or get a reference to the Word application
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0
    
    ' Check if Word is open
    If wdApp Is Nothing Then
        MsgBox "Microsoft Word is not open."
    Else
        ' Get the selected Word document
        Set wdDoc = wdApp.Documents(ListBox1.ListIndex + 1)


'****************NEW STUFF
Dim LastPara As Integer, Cnt As Integer, PageCnt As Integer
Dim ParaCnt As Integer, Myrange As Variant
'find last paragraph
LastPara = wdApp.ActiveDocument.Content.Paragraphs.Count


PageCnt = 1
ParaCnt = 1


'data stored
If LastPara <> 1 Then
'loop paragraphs
For Cnt = 1 To LastPara  'LastPara paragraph(line#)


'loop multi pages
If wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3) > PageCnt Then
Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
Myrange.SetRange Start:=Myrange.Start, _
        End:=wdApp.ActiveDocument.Paragraphs(Cnt - 1).Range.End
Myrange.CopyAsPicture
Call MakeSheet
PageCnt = wdApp.ActiveDocument.Paragraphs(Cnt).Range.Information(3)
ParaCnt = Cnt
End If


' 1 page only or 1 line on last page
If Cnt = LastPara Then
Set Myrange = wdApp.ActiveDocument.Paragraphs(ParaCnt).Range
Myrange.SetRange Start:=Myrange.Start, _
    End:=wdApp.ActiveDocument.Paragraphs(LastPara).Range.End
Myrange.CopyAsPicture
Call MakeSheet
End If
Next Cnt


Else 'lastpara = 1 ie. no data stored
Set Myrange = wdApp.ActiveDocument.Paragraphs(1).Range
Myrange.CopyAsPicture
Call MakeSheet
End If 'lastpara <> 1


'*********End OF NEW STUFF


' Activate Excel application
ThisWorkbook.Activate
End If


' Clean up
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub


Sub MakeSheet()
Dim newSheet As Worksheet, pic As Object
' Add a new worksheet in the current Excel workbook with a unique name in ascending order
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newSheet.Name = FindUniqueSheetName(ThisWorkbook, "Page ")


' Activate the new worksheet
newSheet.Activate


' Select cell A1 in the new worksheet
newSheet.Range("A1").Select


' Paste the clipboard contents as a picture
Set pic = newSheet.Pictures.Paste


'clear the clipboard
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Sub
I added some code to clear the clipboard as it seems that it likes to crash when you start copying and pasting pictures. So you will need to put this API code in a module...
#If VBA7 And Win64 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
#End If
It seem to trial OK but if the last page is not "full" it only shows the portion of the doc that is populated. If this is not OK, some extra code could fix this. HTH. Dave