Sub Test() Dim s As Shape, eff As Effect Dim sr As New ShapeRange For Each s In ActivePage.Shapes For Each eff In s.Effects If eff.Type = cdrLens Then If eff.Lens.Type = cdrLensTransparency Then If eff.Lens.Rate > 80 Then sr.Add s End If Exit For End If Next eff Next s sr.CreateSelection End Sub