Find and replace underlined words for a blank.

Option Explicit 

Sub replaceUnderLineWithSpace() 

Dim sld         As Slide 
Dim sh          As Shape 
Dim startPos    As Long 
Dim shapeText   As String 

    For Each sld In ActivePresentation.Slides 

        For Each sh In sld.Shapes 
            If sh.HasTextFrame Then 
                If sh.TextFrame.HasText Then 
                    startPos = 1 
                    shapeText = sh.TextFrame.TextRange.Text 
                    Do 
                        With sh.TextFrame.TextRange.Characters(Start:=startPos, Length:=1) 
                            If (.Font.Underline = msoTrue) Then 
                                .Text = " " 
                            End If 
                        End With 
                        startPos = 1 + startPos 
                    Loop While (startPos < Len(shapeText)) 
                End If 
            End If 
        Next 

    Next 
End Sub