Sub Test() Dim p1 As Page, p2 As Page, bAddPage As Boolean Dim doc1 As Document, doc2 As Document Set doc1 = ActiveDocument Set doc2 = CreateDocument() bAddPage = False Set p2 = doc2.Pages(1) For Each p1 In doc1.Pages p1.Activate p1.Shapes.All.Copy If bAddPage Then Set p2 = doc2.AddPages(1) p2.ActiveLayer.Paste bAddPage = True Next p1 End Sub