Here is my solution. And it will only change the 2's that are in H2O . Sub SubscriptH2O() Dim srSelection As ShapeRange, srText As ShapeRange, srContains As ShapeRange Dim s As Shape Dim tr As TextRange Set srSelection = ActiveSelectionRange Set srText = srSelection.Shapes.FindShapes(Type:=cdrTextShape) Set srContains = srText.Shapes.FindShapes(Query:= "@com.text.story.text.RegContains('H2O')" ) Optimization = True For Each s In srContains For Each tr In s.Text.Story.Words If Trim(tr) = "H2O" Then tr.Characters(2).Position = cdrSubscriptFontPosition Next tr Next s Optimization = False ActiveWindow.Refresh End Sub Myron, One comment about your code, it is better to use: s.Text.Story.Characters(2).Position = cdrSubscriptFontPosition than s.Text.FontPropertiesInRange(i, 1).Position = cdrSubscriptFontPosition Hope that helps, -Shelby
↧