Sub Test() Dim s As Shape, bAddPage As Boolean Dim doc1 As Document, doc2 As Document Set doc1 = ActiveDocument Set doc2 = CreateDocument() bAddPage = False For Each s In doc1.ActivePage.Shapes() s.Copy If bAddPage Then doc2.AddPages 1 doc2.ActiveLayer.Paste bAddPage = True Next s End Sub