Sub Test() Dim doc1 As Document, doc2 As Document Dim p As Page If Documents.Count <> 2 Then MsgBox "2 documents must be open" Exit Sub End If If ActiveDocument Is Documents(1) Then Set doc1 = Documents(1) Set doc2 = Documents(2) Else Set doc1 = Documents(2) Set doc2 = Documents(1) End If If doc1.Pages.Count > doc2.Pages.Count Then doc2.AddPages doc1.Pages.Count - doc2.Pages.Count End If For Each p In doc1.Pages p.Activate p.Shapes.All.Copy doc2.Pages(p.Index).Activate doc2.ActiveLayer.Paste Next p doc2.ActivateEnd Sub