word VBA 选择题根据选项长度自动排版！求助

xwd21 · 发表于 2019-3-12 13:31

想要一个word 选择题选项自动排版的代码，有大神能帮忙吗？
设计是这样的：原始的素材是选择题若干个，每个选择题题干单独一段，四个选项各一段。

想实现的效果是：自动判断ABCD四个选项的长度，如1四个选项加起来可以放一行，就用将四段合并为一段，四个选项之间加占位符；如2四个选项中最长的没有超过段落可容纳长度的一半但又放不到一行，就将四个选项合并成2行，同一行选项间加占位符。如果最长选项长度超过一半，就仍然保留四行。

原始格式：
1．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干

A．我是选项

B．我是选项

C．我是选项

D．我是选项

2．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干

A．我是选项我是选项我是选项我

B．我是选项我是选项我是选项我

C．我是选项我是选项我是选项我是选项

D．我是选项我是选项

3．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干
A．我是选项我是选项我是选项我是选项我是选项我是选项我是选项我是选项

B．我是选项我是选项我是选项我是选项我是选项我是选项

C．我是选项我是选项

D．我是选项我是选项我是选项

排版后格式：根据选项长短分三种：

1．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干
A．我是选项 B．我是选项 C．我是选项 D．我是选项

2．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干
A．我是选项我是选项我是选项我 B．我是选项我是选项我是选项我
C．我是选项我是选项我是选项我是选项 D．我是选项我是选项

3．我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干我是题干
A．我是选项我是选项我是选项我是选项我是选项我是选项我是选项我是选项
B．我是选项我是选项我是选项我是选项我是选项我是选项
C．我是选项我是选项
D．我是选项我是选项我是选项

ming0018 · 发表于 2019-3-12 15:19

是这个意思吗？

xwd21 · 发表于 2019-3-12 15:41

ming0018 发表于 2019-3-12 15:19
是这个意思吗？

是的，就是这个意思

ming0018 · 发表于 2019-3-12 16:04

xwd21 发表于 2019-3-12 15:41
是的，就是这个意思

Sub main()
Dim doc As Document, Rng As Range, arr, lineCount%
Set doc = ActiveDocument: lineCount = 40
With doc.Content.Find
.Text = "A．[!^13]{1,}^13^13B．[!^13]{1,}^13^13C．[!^13]{1,}^13^13D．[!^13]{1,}^13"
.MatchWildcards = True
Do While .Execute
Set Rng = .Parent
Rng.Text = Replace(Rng.Text, Chr(13) & Chr(13), Chr(13))
If Len(Rng.Text) < lineCount Then
Rng.MoveEnd 1, -1
Rng.Text = Replace(Rng.Text, Chr(13), vbTab)
If Rng.ComputeStatistics(1) > 1 Then
doc.Undo
End If
ElseIf Len(Rng.Text) < lineCount * 2 Then
arr = Split(Rng.Text, Chr(13))
If Len(arr(0)) + Len(arr(1)) < lineCount - 2 And Len(arr(2)) + Len(arr(3)) < lineCount - 2 Then
Rng.Text = arr(0) & vbTab & arr(1) & Chr(13) & arr(2) & vbTab & arr(3) & Chr(13)
If Rng.ComputeStatistics(1) > 2 Then
doc.Undo
End If
End If
End If
Rng.Move 4
Loop
End With
End Sub

复制代码

拿去玩吧

ming0018 · 发表于 2019-3-12 16:45

xwd21 发表于 2019-3-12 15:41
是的，就是这个意思

等吧　代码审核需要时间

413191246se · 发表于 2019-3-13 00:22

又跟 ming 老师学到一点！.ComputeStatistics(1) > 1，我精简不到位。.undo 从来没用过。

xwd21 · 发表于 2019-3-13 09:03

ming0018 发表于 2019-3-12 16:04
拿去玩吧

感谢ming大神！！！！太棒了

tangqingfu · 发表于 2019-3-14 07:30

谢谢ming0018兄分享

xwd21 · 发表于 2019-3-14 11:33

ming0018 发表于 2019-3-12 16:04
拿去玩吧

大神，能不能在此基础上提再新加一些功能的要求？：1.如果选项中含有图片，就不执行选项排版操作；2.对已排版的选项，设置缩进，且让选项在一行中位置分布平均；3排序完后修改选项的字体字号和段落。

ming0018 · 发表于 2019-3-14 14:01

您可以付费完成以上的需求

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

[求助] word VBA 选择题根据选项长度自动排版！求助

评分