如何将两份WORD文档按题目序号结合排在一起

jackyxong · 发表于 2016-7-22 21:52

有两份WORD文档，一份为题目，一份为答案，想用VB或宏将答案复制到对应的题目后面。

hhjjpp · 发表于 2016-7-24 14:37

Sub mate()
Path = ThisDocument.Path
ActiveDocument.SaveAs Path & "\题目答案配对.doc", FileFormat:=wdFormatDocument
Documents.Open Path & "\答案.doc"
i = 1: j = 1
Do
Windows("答案").Activate
If j = 1 Then Selection.HomeKey Unit:=wdStory '找第1个i.时才置于文首
With Selection.Find
.ClearFormatting
.Text = "^13(" & i & ".)*^13"
.Forward = True
.MatchWildcards = True
If .Execute Then
t = Mid(Selection, 2, 999)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=1 '答案包含多段
Do
temp = Selection.Text
Selection.MoveRight Unit:=wdCharacter, Count:=1
If temp = "" Or temp = Chr(13) Then '至文末
n = i + 1
Else
n = InStr(temp, ".")
If n Then '与工作表函数不同，不能用n=IIf(n <> 0, Val(Left(temp, n - 1)), 0)，当n=0时也进入非当前分支会校验表达式Val(Left(temp, n - 1))的
n = Val(Left(temp, n - 1))
Else
n = 0
End If
End If
If n <> i + 1 Then
t = t & temp
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=1
Else
Selection.MoveUp Unit:=wdParagraph, Count:=1
Exit Do
End If
Loop
Else
If j = 1 Then
Exit Do '本次的第1个i.就不存在，可以终结查找
Else
Selection.HomeKey Unit:=wdStory
i = i + 1
j = 1
GoTo nexti '第j个i.不存在，准备找i+1.,此时待找的为第1个i+1.
End If
End If
End With
Windows("题目答案配对").Activate
If j = 1 Then Selection.HomeKey Unit:=wdStory
With Selection.Find '切换到另一文档时，查找参数不能沿用上一文档的，而且with……endwith也许独立出来
.ClearFormatting
.Text = "^13(" & i & ".)*^13"
.Forward = True
.MatchWildcards = True
.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.InsertAfter t
Selection.MoveDown Unit:=wdParagraph, Count:=1 '避免插入的i.影响查找下一个
End With
j = j + 1 '下一个为第j个i.
nexti:
Loop
Windows("答案").Activate
ActiveWindow.Close
End Sub

复制代码

hhjjpp · 发表于 2016-7-24 14:38

分级过于混乱随意，给判断各题结束标记人为制造事端！

jackyxong · 发表于 2016-7-25 08:17

hhjjpp 发表于 2016-7-24 14:38
分级过于混乱随意，给判断各题结束标记人为制造事端！

说的是，所以我想稍微加下排版后再看下，这二份是排了一下的，看是否能实现？

jackyxong · 发表于 2016-7-25 08:31

hhjjpp 发表于 2016-7-24 14:37

10分感谢，但在运行时出现一些报错再现。我现在把文档做了一些前期的处理，把分级和序号等做了一些标准化处理。
比如，加了1、2、4级标题，另外，把所有题目序号都变成了数字加顿号的格式。
看能不能更完美的处理好。

hhjjpp · 发表于 2016-7-26 10:45

jackyxong 发表于 2016-7-25 08:31
10分感谢，但在运行时出现一些报错再现。我现在把文档做了一些前期的处理，把分级和序号等做了一些标准化 ...

Sub mate()
Dim path$, i%, j%, n%, t$, sty As Boolean
path = ThisDocument.path
Documents.Open path & "\题目答案配对.doc"
Documents.Open path & "\题目的答案.doc"
i = 1: j = 1
Do
Windows("题目的答案").Activate
If j = 1 Then Selection.HomeKey Unit:=wdStory '找第1个i、时才置于文首
With Selection.Find
.ClearFormatting
.Text = "^13(" & i & "、)*^13"
.Forward = True
.MatchWildcards = True
If .Execute Then
t = Mid(Selection, 2)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=1 '答案包含多段
Do
temp = Selection.Text
If temp = Chr(13) Then Exit Do
sty = Left(Selection.Style, 2) = "标题" '该段为标题级别
Selection.MoveRight Unit:=wdCharacter, Count:=1
If temp = "" Or temp = Chr(13) Or sty Then '至文末
n = i + 1
Else
n = InStr(temp, "、")
If n Then '与工作表函数不同，不能用n=IIf(n <> 0, Val(Left(temp, n - 1)), 0)，当n=0时也进入非当前分支会校验表达式Val(Left(temp, n - 1))的
n = Val(Left(temp, n - 1))
End If
End If
If n <> i + 1 Then
t = t & temp
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=1
Else
Selection.MoveUp Unit:=wdParagraph, Count:=1
Exit Do
End If
Loop
Else
If j = 1 Then
Exit Do '本次的第1个i、就不存在，可以终结查找
Else
i = i + 1
j = 1
GoTo nexti '第j个i、不存在，准备找i+1、,此时待找的为第1个i+1.
End If
End If
End With
Windows("题目答案配对").Activate
If j = 1 Then Selection.HomeKey Unit:=wdStory
With Selection.Find '切换到另一文档时，查找参数不能沿用上一文档的，而且with……endwith也许独立出来
.ClearFormatting
.Text = "^13(" & i & "、)*^13"
.Forward = True
.MatchWildcards = True
.Execute
sty = False
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=1
If Left(Selection.Style, 2) = "标题" Then
sty = True
Else
temp = Selection.Text
n = InStr(temp, "、")
If n Then
sty = Val(Left(temp, n - 1)) = i + 1
End If
End If
Loop Until sty Or temp = Chr(13) '光标移至下题首或“标题”级别或文末前
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdLine
Selection.InsertAfter Chr(13) & t
Selection.MoveDown Unit:=wdParagraph, Count:=3 '避免插入的i、影响查找下一个
End With
j = j + 1 '下一个为第j个i、
nexti:
Loop
Windows("题目的答案").Activate
ActiveWindow.Close False
End Sub

复制代码

hhjjpp · 发表于 2016-7-26 10:56

本帖最后由 hhjjpp 于 2016-7-26 10:57 编辑

在调试过程中，多文档之间用window().activate切换激活真的容易出错，因为携代码的文档会影响到selection的操作（表面上selection的操作代码对目标文档毫无作用，其实是被操作到携代码的文档中去了），因为调试过程中你实际激活的是”题目答案配对-h.doc“，会使想操作的“题目答案配对”和”题目的答案“的激活状态被破坏，就算你的代码实际上无任何问题！
但是vba又不能建立多个word文档对象、在各文档之间进行切换操作，来替代selection对象的交互，不知大伽们有何良策可分享？

jackyxong · 发表于 2016-7-26 11:43

hhjjpp 发表于 2016-7-26 10:56
在调试过程中，多文档之间用window().activate切换激活真的容易出错，因为携代码的文档会影响到selec ...

对于VBA我不太懂。
有没有可能用模拟键盘操作在二个文档间切换，但前提是能判断到开始与结束。

hhjjpp · 发表于 2016-7-29 16:40

摆脱过多的光标操作：

Sub mate()
Dim path$, i%, j%, n, t$, brr(1 To 300) As String, br
path = ThisDocument.path
Documents.Open path & "\题目的答案.doc"
For j = 1 To ActiveDocument.Paragraphs.Count
With ActiveDocument.Paragraphs(j).Range 'with允许含变量,但以本行及之前的j值为准
If Left(.Style, 2) <> "标题" Then '添加监视ActiveDocument.Paragraphs(j).Range.style
n = InStr(.Text, "、") '添加监视ActiveDocument.Paragraphs(j).Range.Text
If n Then
n = Left(.Text, n - 1)
End If
If IsNumeric(n) And n > 0 Then
i = i + 1 '题序
If i > 1 Then
brr(i - 1) = t '将上次拼连结果赋值到数组
End If
t = "" '拼连初始化
End If
t = t & .Text '段间拼连
End If
End With
Next
brr(i) = t '末题赋值
i = 0: j = 1
ActiveDocument.Close False
Documents.Open path & "\题目答案配对.doc"
Do '由于试题包含图片,答案只能用插入方式,而不能将题目拼连数组和上述答案文本互相掺合
With ActiveDocument.Paragraphs(j).Range
n = InStr(.Text, "、")
If n Then
n = Left(.Text, n - 1)
End If
If IsNumeric(n) And n > 0 Then '与excel不同,IsNumeric可识别文本数字
i = i + 1
If i > 1 Then
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdParagraph, Count:=j - 2 '按段落绝对序数移动光标
br = j - 1
Do While Left(ActiveDocument.Paragraphs(br).Range.Style, 2) = "标题" '题末遇标题样式分类文字,答案插入位置需要上移,直至正文
Selection.MoveUp Unit:=wdParagraph, Count:=1
br = br - 1 '用临时变量,避免影响通篇段落搜索的j值
Loop
Selection.EndKey Unit:=wdLine '插入前光标移至行末
Selection.InsertAfter Chr(13) & brr(i - 1)
Selection.MoveRight Unit:=wdCharacter, Count:=1 '插入答案后要取消选黑状态
j = j + 2 + Len(brr(i - 1)) - Len(Replace(brr(i - 1), Chr(13), ""))
'考虑插入答案后增加了文档段落数,按回车符计算段数，而非用两相邻题收段落序数相减，是因为答案文档夹插了大量、需要扣除的“标题”样式标注
Else
j = j + 1 '首题起始段不需插入操作
End If
Else
If j = ActiveDocument.Paragraphs.Count Then '最后一题无数字结束标记专此处理
Selection.EndKey Unit:=wdStory
Selection.InsertAfter Chr(13) & brr(i)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Exit Do
Else
j = j + 1
End If
End If
End With
Loop
End Sub

复制代码

jackyxong · 发表于 2016-8-1 21:36

hhjjpp 发表于 2016-7-29 16:40
摆脱过多的光标操作：

非常感谢，经过测试，大部分能成功，但目前有二个地方错位，已经在文档里面标识出来并写出了批注。
另外，路径能改成桌面地址吗？C:\Users\Administrator\Desktop

		自动登录	找回密码
密码			免费注册

[求助] 如何将两份WORD文档按题目序号结合排在一起