Sub ExtractPages()
Dim rStart As String
Dim rEnd As String
Dim r As Range
Dim aDoc1 As Document
Dim aDoc2 As Document
Set aDoc1 = ActiveDocument
rStart = InputBox("Start page?")
rEnd = InputBox("End page?")
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=rStart
With aDoc1.Bookmarks
.Add Range:=Selection.Range, Name:="Start"
End With
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=rEnd
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With aDoc1.Bookmarks
.Add Range:=Selection.Range, Name:="End"
End With
Set r = aDoc1.Range(Start:=aDoc1.Bookmarks("Start").Start, _
End:=aDoc1.Bookmarks("End").End)
r.Select
Selection.Copy
Documents.Add DocumentType:=wdNewBlankDocument
Set aDoc2 = ActiveDocument
Selection.Paste
aDoc1.Activate
Selection.Collapse
aDoc1.Bookmarks("End").Delete
aDoc1.Bookmarks("Start").Delete
Set r = Nothing
Set aDoc1 = Nothing
aDoc2.Activate
Set aDoc2 = Nothing
End Sub