以下是引用qianyong在2005-4-14 10:24:00的发言：
再问守斑竹：在主文档中能否改成同时选择几个序号不连续的题目，插入新文档中（在新文档中这几个题目的题号是连续的）？[em06][em06] 这个问题，本在我考虑范围中，只是当时楼主没说，自然我就免了。
注意：以英文逗号作为多题编号之间的分隔符，我没作是否重复的判断，我想，也不需要。
q6onGTQm.rar
(24.38 KB, 下载次数: 26)
以下代码供参考：
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-4-15 4:39:07
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub Example()
Dim MyRange As Range, Lists As String, AnsSecNumber As Integer, Pos As Integer
Dim MyDoc2 As Document, MyDoc3 As Document, MyString As String, InsertParCount As Variant
Dim SecNumber() As String, aList As Variant, aString As String
On Error Resume Next '忽略错误
With Application.Windows(ThisDocument.Name).Selection
.HomeKey wdStory '移到文档首
.Find.Execute findtext:="^m" '查找分页符
AnsSecNumber = .Information(wdActiveEndSectionNumber) '获得分页符所在节号
' MsgBox AnsSecNumber
End With
Lists = InputBox("请输入您想要提取的考试题目编号, " & vbCrLf & _
"以,(英文逗号)为分隔符,可以提取多题!")
If Lists = "" Then Exit Sub
SecNumber = VBA.Split(Lists, ",")
For Each aList In SecNumber
If aList = 0 Or aList > ThisDocument.Sections.Count Then
MsgBox "WORD发现您的输入项中的某一项有0值或者超过活动文档的总节数!", vbOKOnly + vbExclamation
Exit Sub
End If
Next
InsertParCount = InputBox("请输入您想要生成的考试题编号或在该文档中的现有位置编号!")
If InsertParCount = "" Then Exit Sub
InsertParCount = VBA.Val(InsertParCount) - 1
Application.ScreenUpdating = False '关闭屏幕更新
With ThisDocument
For Each aList In SecNumber '在数组中循环
'定义一个RANGE对象,为所需节号+1的位置到连续型分节符前一个位置的区域
Set MyRange = .Range(.Sections(aList + 1).Range.Start, .Sections(aList + 1).Range.End - 2)
Pos = VBA.InStr(MyRange.Text, "．") '获得指定字符的位置
'重新定义一个RANGE对象,从指定字符后开始到连续型分节符前一个位置的区域
Set MyRange = .Range(.Sections(aList + 1).Range.Start + Pos, .Sections(aList + 1).Range.End - 2)
'替换其中的段落标记为手动换行符(使其为一个段落)
aString = VBA.Replace(MyRange.Text, Chr(13), Chr(11)) & Chr(13)
MyString = MyString & aString '累加
Next aList
End With
Set MyDoc2 = Documents("计算机等级考试三级网络试题选.doc") '定义一个WORD文档
With Application.Windows(MyDoc2).Selection
.HomeKey wdStory '移动到文档首位置
.MoveDown wdParagraph, VBA.Val(InsertParCount) '根据需要向下移动指定的段落数
.InsertAfter MyString
.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
End With
aString = "": MyString = "" '初始化变量
With ThisDocument
For Each aList In SecNumber
'定义一个RANGE对象,从分页符位置开始的节加上所需节号,即是答案所在位置
Set MyRange = .Range(.Sections(AnsSecNumber + aList).Range.Start, .Sections(AnsSecNumber + aList).Range.End - 2)
Pos = VBA.InStr(MyRange.Text, ".") '获得指定字符"句点"的位置
'重新RANGE对象
Set MyRange = .Range(.Sections(AnsSecNumber + aList).Range.Start + Pos, .Sections(AnsSecNumber + aList).Range.End - 2)
aString = VBA.Replace(MyRange.Text, Chr(13), Chr(11)) & Chr(13)
MyString = MyString & aString
Next aList
End With
Set MyDoc3 = Documents("计算机等级考试三级网络试选答案.doc") '定义一个文档
With Application.Windows(MyDoc3).Selection
.HomeKey wdStory
.MoveDown wdParagraph, VBA.Val(InsertParCount)
.InsertAfter MyString
.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
'----------------------
| 
楼主: qianyong
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2005-4-14 09:24
