Sub Test() Dim p1 As Page, p2 As Page Dim s As Shape Dim doc As Document Set doc = ActiveDocument Set s = doc.ActiveLayer.CreateRectangle(2, 2, 4, 4) Set s = doc.ActiveLayer.CreateEllipse(1, 2, 3, 4) For Each p1 In doc.Pages p1.Activate p1.Shapes.All.Cut Set p2 = doc.AddPages(1) p2.ActiveLayer.Paste Next p1End Sub