Macro - please - All the pages data into a single page by removing the pages

Sub FlattenPages()
Dim p As Page, s As Shape, sr As ShapeRange
Dim i&
Optimization = True
ActiveDocument.BeginCommandGroup "FlattenPages"
ActivePage.CreateLayer "Work Layer"
For i = 1 To ActiveDocument.Pages.Count
Set sr = ActiveDocument.Pages(i).Shapes.All
For Each s In sr
sr.MoveToLayer ActiveLayer
Next s
Next i
Call delEmptyPages
Call MoveToLayer1
ActiveLayer.Delete
ActiveDocument.EndCommandGroup
Optimization = False
ActiveWindow.Refresh
End Sub

Sub delEmptyPages()
Dim p As Page
For Each p In ActiveDocument.Pages
If p.Shapes.All.Count = 0 Then
p.Delete
End If
If ActiveDocument.Pages.Count = 1 Then
Exit Sub
End If
Next p
End Sub

Sub MoveToLayer1()
Dim shp As Shape
For Each shp In ActiveLayer.Shapes
shp.Layer = ActivePage.Layers("Layer 1")
Next
ActiveWindow.Refresh
End Sub