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+．[^\r]+\(([A-E])\)\r(?:(?!^\d+．[^\r]+\((?:[A-E])\)\r).)+" '匹配题干+选项(非题干的多行,直到第二个题干前),有几个就有多少组 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 WithEnd Sub