Sub Test() Dim s As Shape Dim pwc As PowerClip For Each s In ActivePage.Shapes Set pwc = Nothing On Error Resume Next Set pwc = s.PowerClip On Error GoTo 0 If Not pwc Is Nothing Then s.CreateSelection pwc.ExtractShapes End If Next sEnd Sub