VBA将选项对齐

小花鹿

用VBA将选择题的选项对齐，比较美观，知道用制表符，但不知道如何操作。



将选项对齐.rar (16.03 KB, 下载次数: 29)

2024-3-1 20:22 上传

点击文件名下载附件

413191246se

* 小花鹿 老师：下面是我前两年写的《选项对齐》宏，请试运行之，代码仅供参考。

1. Sub OptionAlign()
   
2. '选项对齐
   
3.     Dim t As Table, i As Paragraph, lenTable!, oTab!, Tab1!, Tab2!, Tab3!
   
4. 
   
5.     With ActiveDocument
   
6.         .Tables.Add .Range(0, 0), 1, 1
   
7.         lenTable = Round(.Tables(1).Cell(1, 1).Width / 28.35, 2)
   
8.         .Tables(1).Delete
   
9.         'cm=char/2.7
   
10.         oTab = (Int((lenTable - 2 * 0.19) * 2.7 + 0.5) - 2) / 4
    
11.         Tab1 = Round((2 + 1 * oTab) / 2.7, 2)
    
12.         Tab2 = Round((2 + 2 * oTab) / 2.7, 2)
    
13.         Tab3 = Round((2 + 3 * oTab) / 2.7, 2)
    
14. 
    
15.         .Content.Find.Execute "^l", , , 0, , , , , , "^p", 2
    
16. 
    
17.         For Each t In .Tables
    
18.             With t.Range.Rows
    
19.                 .WrapAroundText = False
    
20.                 .Alignment = wdAlignRowCenter
    
21.             End With
    
22.         Next
    
23. 
    
24.         With .Content.Find
    
25.             .Execute "(^13)([ 　^s^t]{1,})", , , 1, , , , , , "\1", 2
    
26.             .Execute "([ 　^s^t]{1,})(^13)", , , 1, , , , , , "\2", 2
    
27.             .Execute "([A-D])[.、]", , , 1, , , , , , "\1．", 2
    
28.             .Execute "([ 　^s^t^13]{1,})([B-D]．)", , , 1, , , , , , "^t\2", 2
    
29.             .Execute "(^13)([0-9]{1,})[.、]", , , 1, , , , , , "\1\2．", 2
    
30.         End With
    
31. 
    
32.         For Each i In .Paragraphs
    
33.             With i.Range
    
34.                 If Not .Information(12) Then
    
35.                     If .Text Like "A．*" Then
    
36.                         .Font.Color = wdColorRed
    
37. 
    
38.                         With .ParagraphFormat.TabStops
    
39.                             .ClearAll
    
40.                             .Add Position:=CentimetersToPoints(Tab1)
    
41.                             .Add Position:=CentimetersToPoints(Tab2)
    
42.                             .Add Position:=CentimetersToPoints(Tab3)
    
43.                         End With
    
44. 
    
45.                         If .ComputeStatistics(1) = 2 Then
    
46.                             .Find.Execute "^t(C．)", , , 1, , , , , , "^p\1", 2
    
47.                             With .ParagraphFormat.TabStops
    
48.                                 .ClearAll
    
49.                                 .Add Position:=CentimetersToPoints(Tab2)
    
50.                             End With
    
51.                         ElseIf .ComputeStatistics(1) >= 3 Then
    
52.                             .Find.Execute "^t([B-D]．)", , , 1, , , , , , "^p\1", 2
    
53.                         End If
    
54. 
    
55.                         With .ParagraphFormat
    
56.                             .CharacterUnitFirstLineIndent = 0
    
57.                             .FirstLineIndent = CentimetersToPoints(0)
    
58.                             .CharacterUnitFirstLineIndent = 2
    
59.                         End With
    
60.                     End If
    
61.                 End If
    
62.             End With
    
63.         Next
    
64.     End With
    
65. End Sub

复制代码

蜀中草莽

413191246se 发表于 2024-3-2 01:57
* 小花鹿 老师：下面是我前两年写的《选项对齐》宏，请试运行之，代码仅供参考。

哈哈哈 老师   我就记得 有老师写过这个代码刚刚找这个原贴 没找到  

小花鹿

谢谢两位老师                                                                                                               

batmanbbs

413191246se 发表于 2024-3-2 01:57
* 小花鹿 老师：下面是我前两年写的《选项对齐》宏，请试运行之，代码仅供参考。

问一下，如果有5-6个选项，应该如何处理

小花鹿

2楼代码运行结果与我图片不一样，题号为11、12两个小题的选项本来是不用换行的

batmanbbs

小花鹿 发表于 2024-3-2 11:32
2楼代码运行结果与我图片不一样，题号为11、12两个小题的选项本来是不用换行的

因为文档中的制表符是理想状态，代码生成的是平分位置

小花鹿

batmanbbs 发表于 2024-3-2 16:42
因为文档中的制表符是理想状态，代码生成的是平分位置

我图片的效果是手动设置的，VBA应该能完成这样的效果                                             

413191246se

* batmanbbs 老师，我的代码默认是 4 个（也许 5 个？我忘了！），如果有 5、6 个选项，需要自行扩充代码了！制表位要重新计算。
* 还有，小花鹿 老师、草莽 老师：运行本宏前要自行进行公文排版。
* 也许各位能重新编制出自行适应多个选项的宏，仅作抛砖引玉吧！

小花鹿

想了很长时间，觉得这个问题太复杂，没有思路