替换法移动答案至括号中

weiyingde

要求：将选枝下面【答案】后面的答案项，移到题干后面的括号里。然后删去原答案所在的行。
见附件。谢谢

本专题式求助，得到了几位大侠的热情援手，各位大侠，仁者见仁智者见智，各显身手，让我等茅塞顿开。
本帖问题已经获得完美的解决。
最后，希望和我一样受慧的求助者从有所启发
本帖末尾意外获得版主赐给最简代码，应该是适合本题的最简单的解决方案，正合我意。
我将其以杜老师的模式简写一下，有意者，可以收藏
再次感谢各位大侠，谢谢版主。
代码如下:
Sub 移动答案最简版()
With ActiveDocument.Content.Find
      .Execute "[ 　]@", , , 1, , , , , , "", 2
      .Execute "([\)）]^13)(*)【答案】([A-F]@)^13", , , 1, , , , , , "\3\1\2", 2
End With
End Sub

jiminyanyan

搜索了一下，和这个差不多，您先研究…………
http://club.excelhome.net/thread-1032236-1-1.html

jiminyanyan

搞定…………
Sub 把文档尾段答案逐一写入题干()
    Dim reg As Object, j%
    Set reg = CreateObject("vbscript.regexp")
    With reg
          .Global = True
          .Pattern = "【答案】([A-Z])"
          Set matches = .Execute(ActiveDocument.Content)
    End With
    Set reg = Nothing
    With CreateObject("vbscript.regexp")
          .Global = True
          .MultiLine = True
    j = 0
         Do While j < matches.Count
              For Each para In ActiveDocument.Paragraphs
                  .Pattern = "[（/(]\s*[）/)]"
                  If .test(para.Range) = True Then
                       para.Range = .Replace(para.Range, "（" & matches.Item(j).submatches(0) & "）")
                       j = j + 1
                  End If
              Next
          Loop
    End With
End Sub

jiminyanyan

把答案那一行去掉，应难不住你，我还是写一下吧…………
Sub 宏1()
'
' 宏1 宏
'
'

    With Selection.Find
        .Text = "【答案】[!^13]@^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

小花鹿

记个记号，跟高手学习

weiyingde

jiminyanyan 发表于 2017-5-8 20:50
搞定…………
Sub 把文档尾段答案逐一写入题干()
    Dim reg As Object, j%

谢谢，学习了

weiyingde

jiminyanyan 发表于 2017-5-8 20:50
搞定…………
Sub 把文档尾段答案逐一写入题干()
    Dim reg As Object, j%

这一过程若用word替换法可行吗？

duquancai

Sub 移动答案()
    Dim doc As Document, a(), n&, i&, k&
    Dim p As Range, s As Range, r As Range
    Set doc = ActiveDocument
    If Not doc.Content.Find.Execute("【答案】") Then Exit Sub
    Call DP(doc.Content)
    With doc.Content.Find
        Do While .Execute("^13[0-9]{1,}", , , 1)
            n = n + 1: ReDim Preserve a(n)
            a(n - 1) = .Parent.Start + 1: .Parent.Collapse 0
        Loop
    End With
    a(n) = doc.Content.End
    For i = n To 1 Step -1
        Set p = doc.Range(a(i - 1), a(i)): Set s = p.Duplicate: Set r = p.Duplicate
        With s.Find
            If .Execute("[\)）]^13", , , 1) Then
                s.Collapse: s.MoveStartUntil "(（", wdBackward
                r.Collapse: k = r.MoveUntil("】"): r.Move , 1: r.MoveEndUntil Chr(13)
                If k <> 0 Then
                    s.FormattedText = r.FormattedText
                    p.Collapse: p.MoveUntil "【": p.EndOf 4, wdExtend: p.Text = Empty
                End If
            End If
        End With
    Next
End Sub
Function DP(selectRange As Range)
    sr$ = Chr$(32) & Chr$(9) & ChrW$(12288) & ChrW$(160)
    With selectRange
        With .Find
            .Execute "^11", , , 1, , , , 0, , "^p", 2
            .Execute "^p^w", , , 0, , , , 0, , "^p", 2
            .Execute "^w^p", , , 0, , , , 0, , "^p", 2
        End With
        With .Paragraphs(1).Range
            n& = Len(.Text) - 1: .SetRange .Start, .Start
            If .MoveEndWhile(sr, n) <> 0 Then: .Text = Empty
        End With
    End With
End Function

jiminyanyan

weiyingde 发表于 2017-5-8 22:00
这一过程若用word替换法可行吗？

杜老师已经写了，您可以试着注释一下，注释代码也是一个学习与提高的过程。

小花鹿

我也练习一下：
Sub test()
Dim st, en
With ThisDocument.Range
    With .Find
        Do While .Execute("[0-9]{1,}.*【答案】*^13", , , 1)
            With .Parent
                .Collapse
                .MoveStartUntil Chr(13)
                .MoveEndUntil "（(", wdBackward
                .MoveEndUntil ")）"
                st = .Start: en = .End
                .MoveStartUntil "【答案】"
                .MoveStartUntil Chr(13)
                .MoveEndUntil "】", wdBackward
                .MoveEndUntil Chr(13)
                ThisDocument.Range(st, en).FormattedText = .FormattedText
                .MoveStartUntil Chr(13), wdBackward
                .End = .End + 1
                .Delete
            End With
        Loop
    End With
End With
End Sub