VBA注释临时

Sub shishi() '按ABCDE为多选题定义答案;
'A．沙利度胺 B．异烟肼   C．利福平
'd.氯法齐明 E.氨苯砜
'46．各型麻风病的首选药物为(D)
'A．沙利度胺 B．异烟肼   C．利福平
'd.氯法齐明 E.氨苯砜
'45．各型麻风病的首选药物为(E)
'A．沙利度胺 B．异烟肼   C．利福平
'd.氯法齐明 E.氨苯砜
'45645
'1532131
'46．各型麻风病的首选药物为(D)
    Dim mt, mh, mk, oRng As Range, rg As Range, n&, m&, str$, d, rng As Range ',t
    Set d = CreateObject("Scripting.Dictionary")
    y = 4
    With CreateObject("vbscript.regexp")
        .Global = True: .IgnoreCase = False: .MultiLine = True
        .Pattern = "^d+．[^
]+(([A-E]))
(?:(?!^d+．[^
]+((?:[A-E]))
).)+" '匹配题干+选项(非题干的多行,直到第二个题干前),有几个就有多少组
        For Each mt In .Execute(ActiveDocument.Content)
            y = y + 1 '这个是初始的题号;
            m = mt.FirstIndex: n = mt.Length45.各型麻风病的首选药物为(E)

            Set oRng = ActiveDocument.Range(m, m + n) 'orng为题干+选项;
            str = mt.submatches(0) 'str为题干后答案;
            .Pattern = "([A-E]．)((?:(?![A-E]．).)+)" '匹配ABCDE选项;
            For Each mh In .Execute(oRng.Text)
                m = mh.FirstIndex: n = mh.Length
                Set rg = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n) 'rg为具体选项;
                Set d(Left(rg.Text, 1)) = rg '在字典内创建A与A选项内容间的对应;
            Next
            t = d.items 'item只能有5个,对应A-E5个选项,即t(0)-t(4);
            Select Case y Mod 5 '是5的倍数则分配A,余数为1则分配B,其他以此类推;4为E;
            Case 0
                If str <> "A" Then
                    .Pattern = "(s*[A-E]s*)"
                    For Each mk In .Execute(oRng.Text)
                        m = mk.FirstIndex: n = mk.Length
                        Set rng = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n) '通常二次正则查找时需要用到加两次;
                        With rng
                            .MoveStart 1, 1: .MoveEnd 1, -1: .Text = "A" '这个就是从括号外移动到括号内;
                        End With
                    Next
                    With d(str) '字典直指Range对象(遥控);
                        .MoveStart 1, 2: .MoveEnd 1, -1: s1 = .Text '起点向后移动2,末点向前移动1；
                    End With
                    With t(0) '这里写成d.itme(1)是否可行？AHK中必须写成那样;
                        .MoveStart 1, 2: .MoveEnd 1, -1: s2 = .Text
                        .Text = s1
                    End With
                    d(str).Text = s2
                End If '上面就是交换两个选项内容,而选项自身不变;
            Case 1 '余下的都是重复性操作了,真正核心的也就是上面的代码部分了;
                If str <> "B" Then
                    .Pattern = "(s*[A-E]s*)"
                    For Each mk In .Execute(oRng.Text)
                        m = mk.FirstIndex: n = mk.Length
                        Set rng = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
                        With rng
                            .MoveStart 1, 1: .MoveEnd 1, -1: .Text = "B"
                        End With
                    Next
                    With d(str)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s1 = .Text
                    End With
                    With t(1)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s2 = .Text
                        .Text = s1
                    End With
                    d(str).Text = s2
                End If
            Case 2
                If str <> "C" Then
                    .Pattern = "(s*[A-E]s*)"
                    For Each mk In .Execute(oRng.Text)
                        m = mk.FirstIndex: n = mk.Length
                        Set rng = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
                        With rng
                            .MoveStart 1, 1: .MoveEnd 1, -1: .Text = "C"
                        End With
                    Next
                    With d(str)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s1 = .Text
                    End With
                    With t(2)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s2 = .Text
                        .Text = s1
                    End With
                    d(str).Text = s2
                End If
            Case 3
                If str <> "D" Then
                    .Pattern = "(s*[A-E]s*)"
                    For Each mk In .Execute(oRng.Text)
                        m = mk.FirstIndex: n = mk.Length
                        Set rng = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
                        With rng
                            .MoveStart 1, 1: .MoveEnd 1, -1: .Text = "D"
                        End With
                    Next
                    With d(str)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s1 = .Text
                    End With
                    With t(3)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s2 = .Text
                        .Text = s1
                    End With
                    d(str).Text = s2
                End If
            Case 4
                If str <> "E" Then
                    .Pattern = "(s*[A-E]s*)"
                    For Each mk In .Execute(oRng.Text)
                        m = mk.FirstIndex: n = mk.Length
                        Set rng = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
                        With rng
                            .MoveStart 1, 1: .MoveEnd 1, -1: .Text = "E"
                        End With
                    Next
                    With d(str)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s1 = .Text
                    End With
                    With t(4)
                        .MoveStart 1, 2: .MoveEnd 1, -1: s2 = .Text
                        .Text = s1
                    End With
                    d(str).Text = s2
                End If
            End Select
            d.RemoveAll
        Next
    End With
End Sub

　　附件：

https://files.cnblogs.com/files/zhanglei1371/%E5%AE%9E%E9%AA%8C%E6%8A%A5%E5%91%8A%E5%B0%81%E9%9D%A2.7z