主任名单（宏——完美终结版）

413191246se

* 适用于正文四号/首行缩进2字符版面，否则排版不整齐。
* 算法更新，代码减半，人员无限制！——现在《主任/副主任/成员》或《组长/副组长/成员》三组人员无限制，XXXX工作领导小组办公室主任即使达到100人也可以，副主任达到1000人也可以，成员达到1万人也可以。
* 注意事项：《主任/副主任/成员》或《组长/副组长/成员》这三个关键词，后面必须有冒号跟随（无论半角冒号还是全角冒号），否则程序无法处理。
* 适用于下列格式：（XX 或 XXX 代表人名，如：鲁迅/周树人）
主席：XXX XXX
XXX XX XXX
副组长：XXX XX XXX XX
XXX XX XXX XX
成员：XXX XX XXX XX XXX
XXX XX XXX XX XXX XXX
***《主任名单》宏（完美终结版）代码：

1. Sub 主任名单()
   
2.     If Selection.Type = wdSelectionIP Then MsgBox "请选定<主任/副主任/成员>区域！", vbOKOnly + vbCritical, "主任名单": End
   
3.     CommandBars.FindControl(ID:=122).Execute
   
4.     CommandBars.FindControl(ID:=123).Execute
   
5.     Dim myRange As Range, i As Paragraph, j As Long, k As Long
   
6.     Set myRange = Selection.Range
   
7.     For Each i In myRange.Paragraphs
   
8.         If Not (i.Range Like "*[:：]*") Then i.Range.InsertBefore Text:=" "
   
9.     Next
   
10.     With myRange
    
11.         .Find.Execute findtext:=":", replacewith:="：", Replace:=wdReplaceAll
    
12.         .Find.Execute findtext:="： ", replacewith:="：", Replace:=wdReplaceAll
    
13.         .Find.Execute findtext:="^t", replacewith:=" ", Replace:=wdReplaceAll
    
14.         .Find.Execute findtext:="　", replacewith:=" ", Replace:=wdReplaceAll
    
15.         .Find.Execute findtext:="^s", replacewith:=" ", Replace:=wdReplaceAll
    
16.         .Find.Execute findtext:="^p ", replacewith:=" ", Replace:=wdReplaceAll
    
17.     End With
    
18.     Do
    
19.         myRange.Find.Execute findtext:="  ", replacewith:=" ", Replace:=wdReplaceAll
    
20.     Loop Until myRange.Find.Found = False
    
21.     myRange.Find.Execute findtext:="：", replacewith:="：^p", Replace:=wdReplaceAll
    
22.     myRange.Paragraphs(6).Range.Select: k = 3
    
23. ConSetName:
    
24.     Selection.Find.Execute findtext:=" ", replacewith:="^p", Replace:=wdReplaceAll, Wrap:=wdFindStop
    
25.     For Each i In Selection.Paragraphs
    
26.         If Len(i.Range) = 2 Then i.Range.Characters.Last.Delete: i.Range.Characters(1).InsertAfter Text:=Space(2)
    
27.         If Len(i.Range) = 3 Then i.Range.Characters(1).InsertAfter Text:="  "
    
28.     Next
    
29.     If k = 2 Or k = 1 Then j = Selection.Paragraphs.Count
    
30.     Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=5, AutoFitBehavior:=wdAutoFitFixed
    
31.     Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:=True
    
32.     CommandBars.FindControl(ID:=122).Execute
    
33.     CommandBars.FindControl(ID:=123).Execute
    
34.     Selection.Find.Execute findtext:="^t", replacewith:="   ", Replace:=wdReplaceAll
    
35.     If k = 3 Then
    
36.         Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 6.05
    
37.     ElseIf k = 2 Or k = 1 Then
    
38.         If j > 5 Then Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 6.05
    
39.     End If
    
40.     Selection.Previous(unit:=wdParagraph, Count:=1).Select
    
41.     Selection.Find.Execute findtext:=" ", replacewith:="", Replace:=wdReplaceAll
    
42.     If k = 3 Or k = 1 Then Selection.Characters(1).InsertAfter Text:="　"
    
43.     Selection.Font.Name = "黑体"
    
44.     Selection.Font.Bold = True
    
45.     Selection.Characters.Last.Delete
    
46.     Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2
    
47.     If k = 1 Then Selection.HomeKey unit:=wdLine: End
    
48.     If k = 2 Then Selection.Previous(unit:=wdParagraph, Count:=1).Select: k = 1: GoTo ConSetName
    
49.     Selection.Previous(unit:=wdParagraph, Count:=1).Select: k = 2: GoTo ConSetName
    
50. End Sub

复制代码

413191246se

最新成果，顶一下！