Sub UnderlineStyle()
' Paul Beverley - Version 01.10.18
' Changes the underline style of underlined text

myTypes = ",1,2,3,4,6,7,9,10,11,20,23,25,26,27,39,43,55"
myNum = Split(myTypes, ",")
totNums = UBound(myNum)
myStyle = Val(InputBox("1 - Single" & vbCr & "2 - Words" _
     & vbCr & "3 - Double" & vbCr & "4 - Dotted" & _
     vbCr & "5 - Thick" & vbCr & "6 - Dash" & vbCr _
     & "7 - DotDash" & vbCr & "8 - DotDotDash" & _
     vbCr & "9 - Wavy" & vbCr & "10 - DottedHeavy" _
     & vbCr & "11 - DashHeavy" & vbCr & _
     "12 - DotDashHeavy" & vbCr & "13 - DotDotDashHeavy" _
     & vbCr & "14 - WavyHeavy" & vbCr & "15 - DashLong" _
     & vbCr & "16 - WavyDouble" & vbCr & _
     "17 - DashLongHeavy", "UnderlineStyle"))
If myStyle < 1 Or myStyle > 17 Then Beep: Exit Sub

myUnderline = Val(myNum(myStyle))
For i = 1 To totNums
  If i <> myStyle Then
    If Selection.Start = Selection.End Then
      Set rng = ActiveDocument.Content
    Else
      Set rng = Selection.range.Duplicate
    End If
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Font.Underline = Val(myNum(i))
      .Replacement.Font.Underline = myUnderline
      .Replacement.Text = ""
      .Wrap = False
      .MatchCase = False
      .Execute Replace:=wdReplaceAll
    End With
  End If
Next i
End Sub