Sub Test() Dim s As Shape Dim lr As Layer Set lr = ActivePage.CreateLayer("Rectangles") For Each s In ActivePage.FindShapes(Type:=cdrRectangleShape) s.Layer = lr Next sEnd Sub