Sub Delete_Underlines()
'Graham Mayor - http://www.gmayor.com - Last updated - 06 Oct 2018
'Adapted by y Greg Maxey, http://gregmaxey.com/word_tips.html, 10/7/2018
' Delete_Underlines Macro
' Will delete all underlines in Document except in Mail addresses (& hyperlinks ??)
Const strUline As String = "1|2|3|4|6|9|10|11|20|23|25|26|27|39|43|55"
Dim vUline As Variant
Dim oRng As Range
'Dim oWord As Range Deleted GKM
Dim i As Long
Dim lngCount As Long 'Added GKM
Dim arrRanges() As String 'Added GKM
  vUline = Split(strUline, "|")
  For i = 0 To UBound(vUline)
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      .Font.Underline = CLng(vUline(i))
      .Replacement.ClearFormatting
      Do While .Execute()
        If oRng.Hyperlinks.Count = 0 Then
          'Instead of processig here, just collect the affected ranges.
           ReDim Preserve arrRanges(lngCount)
           arrRanges(lngCount) = oRng.Start & "|" & oRng.End
           lngCount = lngCount + 1
           oRng.Collapse 0
        End If
     Loop
    End With
  Next i
  'Sort the affected ranges.
  WordBasic.SortArray arrRanges
  Set oRng = ActiveDocument.Range
  'Process the affected ranges in the order they occur.
  For i = 0 To UBound(arrRanges)
    oRng.Start = Split(arrRanges(i), "|")(0)
    oRng.End = Split(arrRanges(i), "|")(1)
    oRng.Select
    If MsgBox("Do you want to remove underline from this instance", vbYesNo) = vbYes Then
        oRng.Font.Underline = wdUnderlineNone
    End If

  Next i
lbl_Exit:
  Set oRng = Nothing
  'Set oWord = Nothing Deleted GKM
  Exit Sub
End Sub