批量抠出所选范围的下划线文字为答案

Sub 批量抠出下划线文字为答案()
    
    Dim daanAll As String
    Dim i, i1, j, k, k1, l As Integer
    
    j = Selection.Range.Start'保存选中区域的范围
    k = Selection.Range.End
    If j = k Then
    Exit Sub
    End If
    Selection.SetRange Start:=k, End:=k
    查找选中下划线文字向上
    k1 = Selection.Range.End '记录最后一个下划线的末端位置
    
    Selection.SetRange Start:=j, End:=j
    Do
        查找选中下划线文字
        l = Selection.Range.End
        daanAll = daanAll & Selection.Range.Text & "；"
        Debug.Print daanAll
        i = i + 1
    Loop Until l >= k1
    
    Selection.SetRange Start:=k, End:=k '回到选中区域的末端
    Selection.TypeParagraph '回车
    Selection.TypeParagraph '回车
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdMove '光标上移一位
    Selection.Font.Color = 236
    Selection.TypeText Text:="【答案】" & daanAll

    
    '下划线字替换为下划线空格
    Selection.SetRange Start:=j, End:=j '回到开始的地方
    l = j
    Do
    选中单个下划线字
    l = Selection.Range.End
    'Selection.SetRange Start:=l, End:=l '回到上一次替换横线的地方
    输入下划线空格
        If l >= k1 Or i1 > 1000 Then
        Exit Do
        Else
        k1 = k1 + 1
        i1 = i1 + 1
        End If
    Loop
    Selection.SetRange Start:=k, End:=k
    MsgBox ("已抠出" & i & "处答案")
    Debug.Print "已抠出" & i & "处答案"

End Sub

Function 查找选中下划线文字()
' Macro1 Macro
' 宏由 ZPL 录制，时间: 2022/11/26
'

'
    ActiveDocument.Range(0, 1).Start = 1
    ActiveDocument.Range(1, 1).End = 1
    With Selection.Find.Font
        .Underline = 9999999
        .EmphasisMark = 9999999
        .Underline = wdUnderlineSingle
        .Underline = wdUnderlineSingle
        .SmallCaps = 0
        .AllCaps = 0
        .DisableCharacterSpaceGrid = False
        .NameFarEast = ""
        .NameAscii = ""
        .NameOther = ""
        .NameBi = ""
        .Bold = wdUndefined
        .Italic = wdUndefined
        .BoldBi = wdUndefined
        .ItalicBi = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .StrikeThrough = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .SmallCaps = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Scaling = wdUndefined
    End With
    With Selection.Find
        .Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchWholeWord = False
        .MatchFuzzy = False
        .Replacement.Text = ""
    End With
    With Selection.Find
        .Style = ""
        .Highlight = wdUndefined
        With .Replacement
            .Style = ""
            .Highlight = wdUndefined
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceNone
End Function


Function 选中单个下划线字()
'
' 选中单个下划线字 Macro
' 宏由 ZPL 录制，时间: 2022/11/27
    Selection.Find.Font.Reset
    Selection.Find.ParagraphFormat.Reset
    Selection.Find.Font.Underline = wdUnderlineSingle
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .SmallCaps = 0
        .AllCaps = 0
        .DisableCharacterSpaceGrid = False
        .NameFarEast = ""
        .NameAscii = ""
        .NameOther = ""
        .NameBi = ""
        .Bold = wdUndefined
        .Italic = wdUndefined
        .BoldBi = wdUndefined
        .ItalicBi = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .StrikeThrough = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .SmallCaps = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Scaling = wdUndefined
    End With
    With Selection.Find.Font
        .Underline = wdUnderlineSingle
        .SmallCaps = 0
        .AllCaps = 0
        .DisableCharacterSpaceGrid = False
        .NameFarEast = ""
        .NameAscii = ""
        .NameOther = ""
        .NameBi = ""
        .Bold = wdUndefined
        .Italic = wdUndefined
        .BoldBi = wdUndefined
        .ItalicBi = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .StrikeThrough = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .SmallCaps = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Scaling = wdUndefined
    End With
    With Selection.Find
        .Text = "?"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = True
        .MatchByte = True
        .MatchWildcards = True
        .MatchWholeWord = False
        .MatchFuzzy = False
        .Replacement.Text = "    "
    End With
    With Selection.Find
        .Style = ""
        .Highlight = wdUndefined
        With .Replacement
            .Style = ""
            .Highlight = wdUndefined
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceNone
    Selection.Find.Replacement.Text = "    "
End Function
Function 输入下划线空格()
'
' 输入下划线空格 Macro
' 宏由 ZPL 录制，时间: 2022/11/27
    With Selection.Font
        .Underline = wdUnderlineSingle
        .UnderlineColor = wdColorAutomatic
    End With
    Selection.TypeText Text:="  "
End Function

Function 查找选中下划线文字向上()
' Macro1 Macro
' 宏由 ZPL 录制，时间: 2022/11/26

    ActiveDocument.Range(0, 1).Start = 1
    ActiveDocument.Range(1, 1).End = 1
    With Selection.Find.Font
        .Underline = 9999999
        .EmphasisMark = 9999999
        .Underline = wdUnderlineSingle
        .Underline = wdUnderlineSingle
        .SmallCaps = 0
        .AllCaps = 0
        .DisableCharacterSpaceGrid = False
        .NameFarEast = ""
        .NameAscii = ""
        .NameOther = ""
        .NameBi = ""
        .Bold = wdUndefined
        .Italic = wdUndefined
        .BoldBi = wdUndefined
        .ItalicBi = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .StrikeThrough = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .SmallCaps = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Scaling = wdUndefined
    End With
    With Selection.Find
        .Text = ""
        .Forward = False
        .Wrap = wdFindContinue
        .MatchCase = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchWholeWord = False
        .MatchFuzzy = False
        .Replacement.Text = ""
    End With
    With Selection.Find
        .Style = ""
        .Highlight = wdUndefined
        With .Replacement
            .Style = ""
            .Highlight = wdUndefined
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceNone
End Function

下面是运行前后的图