Function Find_Underline(Rng As Range) As String
Dim i As Integer
For i = 1 To Len(Rng.Value)
With Rng
If .Characters(Start:=i, Length:=1).Font.Underline <> xlUnderlineStyleNone Then
Underline = Underline & .Characters(i, 1).Caption
Else
If Mid(Rng, i, 1) = Chr(32) Then Underline = Underline & Mid(Rng, i, 1)
End If
End With
Next i
Find_Underline = Application.Trim(Underline)
End Function