如何用代码把答案输入到括号中

zzpsx

如何用代码把答案输入到括号中.rar (12.21 KB, 下载次数: 10)

2020-9-4 14:32 上传

点击文件名下载附件

zzpsx

看来这个题目很难，

413191246se

1. Sub aaaa用代码把答案输入到括号中()
   
2.     Dim i$, j&, k&, arr, r As Range, t As Table, n&
   
3.     With Selection
   
4.         If Not .Information(12) Then MsgBox "请将光标放在表格中！", 0 + 16: End
   
5.         Set t = .Tables(1)
   
6.         .Start = .Tables(1).Range.Next.Start
   
7.         Do While Not .Paragraphs(1).Range Like "参考答案*"
   
8.             .Move 4
   
9.             n = n + 1
   
10.             If .Paragraphs(1).Range.End = ActiveDocument.Content.End Then Exit Do
    
11.         Loop
    
12.         If n > 3 Then End
    
13.         If Not .Paragraphs(1).Range Like "参考答案*" Then End
    
14.         i = .Paragraphs(1).Range.Text
    
15.         i = Mid(i, 6, Len(i) - 6)
    
16.         i = Replace(i, "  ", " ")
    
17.         i = Replace(i, ".", "")
    
18.         arr = Split(i, " ")
    
19.     End With
    
20.     With t
    
21.         k = .Columns(1).Cells.Count
    
22.         For j = 1 To k
    
23.             Set r = .Cell(j, 1).Range
    
24.             With r
    
25.                 .Text = "（ " & arr(j - 1) & " ）"
    
26.                 If .Text Like "（ [0-9]*" Then .Characters(3).Delete
    
27.                 If .Text Like "（ [0-9]*" Then .Characters(3).Delete
    
28.             End With
    
29.         Next
    
30.         .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
31.     End With
    
32. End Sub

复制代码

cuanju

Sub d()
    Application.ScreenUpdating = False
    Rem 注意如果答案比题干少，程序会报错
    '删除最后一段空段
    If Len(ActiveDocument.Paragraphs.Last.Range.Text) < 2 Then
        ActiveDocument.Paragraphs.Last.Range.Select
        Selection.TypeBackspace
    End If
    ActiveDocument.Content.Find.Execute FindText:="([\(（])[ 　^s]{1,}([）\)])", ReplaceWith:="\1\2", Replace:=wdReplaceAll, MatchWildcards:=True '删除选择题题干括号内空格
    arr = Split(Replace(ActiveDocument.Paragraphs.Last.Range, Chr(13), ""), ".") '答案必须在最后一段，且必须按“.”分割
    'Stop
    With ActiveDocument.Content.Find
        .Text = "[\(（][\)）]" '查找题干空格
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            With .Parent
                If i >= UBound(arr) Then MsgBox "题目与答案不一致！": Exit Sub
                i = i + 1
                ActiveDocument.Range(.End - 1, .End - 1).InsertAfter DoRegExp(arr(i), "[^A-F]", "")
                .Collapse 0
            End With
        Loop
    End With
    Application.ScreenUpdating = True
    MsgBox "操作完毕！"
End Sub

Private Function DoRegExp(ByVal sOrignText As String, ByVal sPattern As String, Optional sReplaceText As String = "")
    Dim oRegExp As Object
    Dim oMatches As Object
    Dim oSubMatches As Object
    Dim oMatch As Object
    Dim str1 As String
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
        .Global = True
        .IgnoreCase = True
        .Pattern = sPattern
        If .Test(sOrignText) Then
            Set oMatches = .Execute(sOrignText)
            DoRegExp = .Replace(sOrignText, sReplaceText)
        Else
            DoRegExp = sOrignText
        End If
    End With
    Set oRegExp = Nothing
    Set oMatches = Nothing
End Function