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