Selection to New Page - Macro - Update

working brother.  

can you please add fit to page for this new selection in new page 

Sub MoveSelectionToNewPage()
'MOVE SELECTED SHAPES TO NEW PAGE
Dim sr As ShapeRange
Set sr = ActiveSelectionRange
sr.Cut 'Move Selection
'sr.Copy 'Copy Selection
ActiveDocument.AddPages 1
ActivePage.ActiveLayer.Paste
myname = InputBox("Page Name?", "RENAME PAGE")
If Trim(myname <> "") Then
ActivePage.Name = myname
End If

'FIT TO PAGE
myfactorwidth = ActivePage.SizeWidth / ActivePage.Shapes.All.SizeWidth
myfactorhight = ActivePage.SizeHeight / ActivePage.Shapes.All.SizeHeight
If myfactorwidth < myfactorhight Then
myfactor = myfactorwidth
Else
myfactor = myfactorhight
End If

ActivePage.Shapes.All.StretchEx ActivePage.CenterX, ActivePage.CenterY, myfactor
ActivePage.Shapes.All.CenterX = ActivePage.CenterX
ActivePage.Shapes.All.CenterY = ActivePage.CenterY
End Sub

This error is coming brother