试题中的解析部分在试卷最后，如何提取到每个题干的后面？

fanping

在整理一套试卷，试题的解析再试卷的最后，如何把它提取到每个题干的后面？
有很多道题，手动复制粘贴不符合懒人精神的！
先行谢谢了。

wdpfox

要发上具体的文档，才能使帮助你的大神的作品更具普适性。

fanping

wdpfox 发表于 2020-3-7 08:56
要发上具体的文档，才能使帮助你的大神的作品更具普适性。

好的。谢谢。

fanping

示例文件，请大神帮忙。 示例.rar (12.16 KB, 下载次数: 36)

2020-3-7 15:01 上传

点击文件名下载附件
示例word文件

fanping

顶一下吧，请大神帮忙。

zhanglei1371

第一步：选择题目部分：
替换：^13([A-D].[!^13]@)
为：#\1
第二步选择答案部分：
替换：^13(【解答】)
为：#\1
第三步：分别选定题干和答案==>文本转换为表格，得到2个表格；
第四步：将第二个表格粘贴到第一个表右边==>表格转文本，分隔符@；
第五步：
替换[#\@]
为^p
OK.

zhanglei1371

      重复了        

乐乐2006201505

zhanglei1371 发表于 2020-3-9 21:16
第一步：选择题目部分：
替换：^13([A-D].[!^13]@)
为：#\1

能不能做成VBA代码，对这种重复性工作来说就方便多了。

乐乐2006201505

断断续续做了一天，以6楼思路录制和选定相应位置的代码终于完工了。共享，并供有需要的坛友下载。也希望得到论坛高手斧正。
Sub 将答案解析提取到每个题干后() '特别提醒：答案和解析之间必须最少有一行空行，并且不能出现中间不能出现任何其他文字。如本例中，去掉“答案及解析：”字样，在答案后面也不能有其他任何其他文字
  'http://club.excelhome.net/thread-1524588-1-1.html
  Application.ScreenUpdating = False  '关闭屏幕刷新，成倍提高效率
  Application.DisplayAlerts = False '关闭提示
  Dim doc As Document, i As Paragraph
  Set doc = ActiveDocument
  Selection.WholeStory
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  For Each i In doc.Paragraphs
    k = k + 1
    With i.Range
      If Len(i.Range) = 1 Then  'http://club.excelhome.net/thread-1459894-1-1.html
        r = k - 1: Exit For
      End If
    End With
  Next
  'https://wenda.so.com/q/1463071157728730
  doc.Range(Start:=doc.Paragraphs(1).Range.Start, End:=doc.Paragraphs(r).Range.End).Select
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = "^13([A-D].[!^13]@)"
    .Replacement.Text = "#\1"
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
  End With
  Selection.Find.Execute Replace:=wdReplaceAll
  Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
     NumRows:=3, AutoFitBehavior:=wdAutoFitFixed
  With Selection.Tables(1)
    .Style = "网格型"
    .ApplyStyleHeadingRows = True
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True
    .ApplyStyleLastColumn = False
  End With
  Selection.WholeStory
  With doc    '压栈，提高一定效率
    aCount = .Paragraphs.Count   '避免循环节中每次都读取对象，提高一定效率
    For i1 = aCount To 1 Step -1  '段落从后往前循环
      If Len(.Paragraphs(i1).Range) = 1 Then Exit For '只有一次对象读取，不定义变量
    Next
  End With  '出栈，释放内存
  '请教高手:VBA中如何实现选择word中第二段到最后一段的文本。急呀!!!_360问答  https://wenda.so.com/q/1399994550062778
  doc.Range(doc.Paragraphs(i1 + 1).Range.Start, doc.Range.End).Select
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = "^13(【解答】)"
    .Replacement.Text = "#\1"
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
  End With
  Selection.Find.Execute Replace:=wdReplaceAll
  Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
     NumRows:=3, AutoFitBehavior:=wdAutoFitFixed
  With Selection.Tables(1)
    .Style = "网格型"
    .ApplyStyleHeadingRows = True
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True
    .ApplyStyleLastColumn = False
  End With
'  http://blog.sina.com.cn/s/blog_3fcc205b0102xlzc.html
  Selection.Cut
  ActiveWindow.ActivePane.VerticalPercentScrolled = 0
  Selection.HomeKey wdStory
  With Selection
    For pc = 1 To .Tables(1).Range.Paragraphs.Count
      If Not .Information(12) Then
        Call MoveToDocEndParagraph
      Else
        Call MoveToDocEndParagraph
        Selection.Paste: Exit For
      End If
    Next
  End With
  Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _
    NestedTables:=True
  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = "[#\@]"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
  End With
  Selection.Find.Execute Replace:=wdReplaceAll
  Call 删除尾部空行
  Application.DisplayAlerts = True '开启提示
  Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub

Sub MoveToDocEndParagraph()
  '移动光标至当前段落的结尾
  Selection.MoveDown Unit:=wdParagraph
End Sub

Sub 删除尾部空行()
  'Excel WORD中选择最后一个字符至最后一个回车符号的VBA代码。怎么写。-Word-ExcelHome技术论坛 -  http://club.excelhome.net/thread-1181449-1-1.html
  Application.ScreenUpdating = False  '关闭屏幕刷新，成倍提高效率
  Dim aCount&, i&
  With ActiveDocument    '压栈，提高一定效率
    aCount = .Paragraphs.Count   '避免循环节中每次都读取对象，提高一定效率
    For i = aCount To 1 Step -1  '段落从后往前循环
      If .Paragraphs(i).Range.Text <> Chr(13) Then Exit For  '只有一次对象读取，不定义变量
          '段落字符不是回车符时退出循环，i为最后一个有字符的段落号
    Next
    .Range(.Paragraphs(i).Range.End, .Content.End).Delete  '删除段落i的末尾到文档的末尾范围。减少对象删除次数。
  End With  '出栈，释放内存
  Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub

乐乐2006201505

另一种代码。具有更广泛的拓展性。
Sub 提解析()
  Dim isr As String
  With ActiveDocument.Content
    With .Find
      Do While .Execute("[0-9]{1,2}.[答][案][：]*^13[【解答】]*^13", , , 1, , , 1)
        n = n + 1
        isr = isr & .Parent.Text
      Loop
    End With
    Selection.HomeKey unit:=wdStory
    ActiveDocument.Content.Find.Execute "[0-9]{1,2}.[答][案][：]*^13[【解答】]*^13", , , 1, , , 1, , , "", 2 '删除选项后的解析
    With ActiveDocument
      With .Range(.Range.End - 1, .Range.End - 1)
        .InsertAfter vbCr
        .InsertAfter isr
      End With
    End With
  End With
  Selection.EndKey unit:=wdStory
  '删除当前行 word vba 控制光标常用代码_ssson的专栏-CSDN博客  https://blog.csdn.net/ssson/article/details/88771194
  Selection.HomeKey unit:=wdLine
  Selection.EndKey unit:=wdLine, Extend:=wdExtend
  Selection.Delete
End Sub