金字塔： 相互学习VBA之一[3.8]

konggs

以下是引用[I]chenhuafu[/I]在2006-3-9 18:51:15的发言：

为了加强学习，我向孔兄提一个问题，就是我们在出题目的时候，如果答案项比较短的，那么把答案项通过制表位隔开放在同一行，如果稍长一点，放在两行，如果答案项实在超出页面的一半（只要4个选项中有一个这样），则每个答案项各占一行（段落）。

同时，采用这种设置的只是答案项，对于题干部分不管多长都要占一行（段落）。

我昨天用手工的方法重新设置了1000题，由于手脚快、几近机械化操作了，也要花50分钟才能最后整理完毕。主要是为了节省打印纸。

我来想想。 Collapse 方法 将某一区域或所选内容折叠到起始位置或结束位置。折叠之后起始位置和结束位置相同。 expression.Collapse(Direction) expression 必需。该表达式返回一个 Range 或 Selection 对象。 Direction Variant 类型，可选。指折叠某区域或所选内容的方向。可以是下列 WdCollapseDirection 常量之一：wdCollapseEnd 或 wdCollapseStart。默认值为 wdCollapseStart。 说明 如果用 wdCollapseEnd 折叠一个代表完整段落的区域，则该区域将定位于段落结束标记之后（即下段开头）。但是，在该区域折叠后，可以用 MoveEnd 方法将区域回移一个字符。如下例所示： Set myRange = ActiveDocument.Paragraphs(1).Range myRange.Collapse Direction:=wdCollapseEnd myRange.MoveEnd Unit:=wdCharacter, Count:=-1 示例 本示例将所选内容折叠为选定部分的开头。 Selection.Collapse Direction:=wdCollapseStart 本示例将 myRange 设置为代表活动文档内容区域，折叠 myRange，然后在文档的最后插入一个 2ｘ2 表格。 Set myRange = ActiveDocument.Content myRange.Collapse Direction:=wdCollapseEnd ActiveDocument.Tables.Add Range:=myRange, NumRows:=2, NumColumns:=2

[此贴子已经被作者于2006-3-9 20:56:41编辑过]

konggs

匆匆做了一个，不太好。

陈兄如果要用的话，先用着。Option Explicit Sub 排1() Dim apar As Paragraph Dim arange As Range, brange As Range, a%, b% Dim x% '这个是主程序，运行它就行了！ '要选中某个区域，才行，否则，错 自动去段落 On Error Resume Next Application.ScreenUpdating = False For Each apar In Selection.Paragraphs If apar.Range.Characters(1) Like "A" Then a = apar.Range.Information(wdFirstCharacterLineNumber) Set brange = ActiveDocument.Range(apar.Range.End, apar.Range.End) b = brange.Information(wdFirstCharacterLineNumber) x = b - a Select Case x Case 0 '不做任何处理，即全部在第一行 Case 1 '做处理2，分为二行 With apar.Range.Find .Text = "(*^t*)(^t)" .MatchWildcards = True With .Replacement .Text = "\1^p" End With .Execute Replace:=wdReplaceAll, Forward:=True End With Case 2 '做处理3，分成三行 With apar.Range.Find .Text = "^t" .MatchWildcards = True With .Replacement .Text = "^p" End With .Execute Replace:=wdReplaceAll, Forward:=True End With '做处理3 End Select End If Next 自动A Application.ScreenUpdating = True End Sub Sub 自动去段落() With Selection.Find .Text = "([A-C]、*)^13" .MatchWildcards = True With .Replacement .Text = "\1^t" End With .Execute Replace:=wdReplaceAll, Forward:=True End With End Sub Sub 自动A() Dim apar As Paragraph For Each apar In Selection.Paragraphs If apar.Range.Characters(1) Like "C" And Len(apar.Range.Text) < 25 Then With apar.Find .Text = "^t" .MatchWildcards = True With .Replacement .Text = "^t^t" End With .Execute Replace:=wdReplaceAll, Forward:=True End With Next End Sub

[此贴子已经被作者于2006-3-9 22:33:00编辑过]

konggs

忘了加错误与屏幕之类的代码，你加吧。

sherrywang

学习