如何批量给1-15这些数字加下划线

zzpsx

要实现如图效果，
朋友帮我写了代码，运行很流畅，不过15这个数字需要手动加下划线，请高手看看这段代码可否再完善，或者有别的代码，谢谢。
Sub 选中后数字变红下划线()
Set Arng = Selection.Range
    With Arng.Find
        iflag = Arng.End
        Do While .Execute("[0-9]{1,}", , , 1)
            Set oRng = .Parent
            'oRng.Start = oRng.Start + 1
            Debug.Print oRng.End
            If oRng.End <= iflag Then
                dm = oRng.Text
                oRng.Text = "  " & dm & "  "
                oRng.Font.Underline = wdUnderlineSingle
                oRng.Font.Color = vbRed
                oRng.Collapse 0
            End If
        Loop
    End With
End Sub 数字如何变成红色下划线.rar (4 KB, 下载次数: 5)

2018-4-14 12:41 上传

点击文件名下载附件

QQ214189912

            If orng.End <= iflag Then                 iflag = iflag + 4                 dm = orng.Text

413191246se

Sub 数字加下划线()
    Dim r As Range, s As Range
    With Selection
        If .Type = wdSelectionIP Then MsgBox "请选定要给数字加下划线区域！", 0 + 16: End
        Set r = .Range
        Set s = .Range
        With r.Find
            .ClearFormatting
            Do While .Execute("[0-9]{1,}", , , 1, , , 1)
                With .Parent.Font
                    r.Text = "  " & r.Text & "  "
                    .Color = wdColorRed
                    .Underline = wdUnderlineSingle
                    .UnderlineColor = wdColorRed
                    r.SetRange Start:=r.End, End:=s.End
                End With
            Loop
        End With
    End With
End Sub