证书表格合并（宏）更新！

413191246se

* 证书数据源一个字段：姓名、课题、单位、等级、证书编号。
* 请将代码复制到空白文档后，全选，剪切，再粘贴到 VBE 中，以防乱码！

1. Sub CertificateTablesMerge()
   
2. '证书表格合并
   
3.     Dim t As Table, c As Cell, arr, i&, oRow&, oCol&, xRow&
   
4. 
   
5.     arr = Split("证书编号/课题/姓名/单位/等级", "/")
   
6. 
   
7.     With ActiveDocument
   
8.         For Each t In .Tables
   
9.             t.Rows.WrapAroundText = False
   
10.             For Each c In t.Rows(1).Cells
    
11.                 With c.Range
    
12.                     If .Text Like "*编*号*" Then
    
13.                         .Text = "证书编号"
    
14.                     ElseIf .Text Like "*[课题]*[题目]*" Then
    
15.                         .Text = "课题"
    
16.                     ElseIf .Text Like "*姓*名*" Then
    
17.                         .Text = "姓名"
    
18.                     ElseIf .Text Like "*[单学]*[位校]*" Then
    
19.                         .Text = "单位"
    
20.                     ElseIf .Text Like "*[等奖]*[级项次]*" Then
    
21.                         .Text = "等级"
    
22.                     End If
    
23.                 End With
    
24.             Next
    
25.         Next
    
26. 
    
27.         If Not .Characters(1).Information(12) Then .Range(0, .Tables(1).Range.Start).Delete
    
28.         If Not .Characters(1).Information(12) Then .Range(0, .Tables(1).Range.Start).Delete
    
29.         Selection.HomeKey 6
    
30.         Selection.SplitTable
    
31.         .Tables.Add .Range(0, 0), 2, 5, 1
    
32.         Set t = .Tables(1)
    
33.         With t.Rows(1)
    
34.             For i = 0 To UBound(arr)
    
35.                 .Cells(i + 1).Range.Text = arr(i)
    
36.             Next
    
37.         End With
    
38. 
    
39.         Do While .Tables.Count > 1
    
40.             xRow = t.Range.Information(wdMaximumNumberOfRows)
    
41.             For i = 0 To UBound(arr)
    
42.                 For Each c In .Tables(2).Rows(1).Cells
    
43.                     If c.Range.Text Like arr(i) & "*" Then
    
44.                         c.Select
    
45.                         With Selection
    
46.                             oCol = .Information(wdEndOfRangeColumnNumber)
    
47.                             oRow = .Information(wdMaximumNumberOfRows)
    
48.                             ActiveDocument.Range(Start:=.Tables(1).Cell(2, oCol).Range.Start, _
    
49.                                 End:=.Tables(1).Cell(oRow, oCol).Range.End).Select
    
50.                             .Cut
    
51.                             t.Cell(xRow, i + 1).Range.Select
    
52.                             .HomeKey
    
53.                             .Paste
    
54.                         End With
    
55.                     End If
    
56.                 Next
    
57.             Next
    
58.             .Tables(2).Delete
    
59.             t.Select
    
60.             Selection.InsertRowsBelow 1
    
61.         Loop
    
62. 
    
63.         .Range(Start:=t.Range.End, End:=.Content.End).Delete
    
64.     End With
    
65. 
    
66.     TableProcess
    
67.     TableDeleteBlankRows
    
68. End Sub
    
69. 
    
70. Sub TableProcess()
    
71. '表格处理
    
72.     Dim t As Table, c As Cell, i As Paragraph, a&
    
73. 
    
74.     If Selection.Information(wdWithInTable) = True Then a = 1
    
75. 
    
76.     For Each t In ActiveDocument.Tables
    
77.         If a = 1 Then Set t = Selection.Tables(1)
    
78.         With t
    
79.             '取消环绕/左对齐/左缩进
    
80.             With .Rows
    
81.                 .WrapAroundText = False
    
82.                 .Alignment = wdAlignRowLeft
    
83.                 .LeftIndent = CentimetersToPoints(0)
    
84.                 .HeightRule = wdRowHeightAtLeast
    
85.                 .Height = CentimetersToPoints(0.9)
    
86.             End With
    
87. 
    
88.             '清除格式
    
89.             With .Range
    
90.                 .Next.InsertParagraphBefore
    
91.                 .MoveEnd
    
92.                 .Select
    
93.                 Selection.ClearFormatting
    
94.                 CommandBars.FindControl(ID:=122).Execute
    
95.                 .MoveEnd 1, -1
    
96.                 .Next.Delete
    
97.                 With .Font
    
98. '                    If Not ActiveDocument.Characters.Last.Font.Color = wdColorAutomatic Then
    
99.                     .Color = wdColorBlue
    
100.                     .Kerning = 0
     
101.                     .DisableCharacterSpaceGrid = True
     
102.                 End With
     
103.                 With .ParagraphFormat
     
104.                     .AutoAdjustRightIndent = False
     
105.                     .DisableLineHeightGrid = True
     
106.                 End With
     
107.                 .Cells.VerticalAlignment = wdCellAlignVerticalCenter
     
108.             End With
     
109. 
     
110.             '删除空段
     
111.             For Each c In .Range.Cells
     
112.                 For Each i In c.Range.Paragraphs
     
113.                     If Asc(i.Range) = 13 And Len(i.Range) = 1 Then i.Range.Delete
     
114.                 Next
     
115.                 With c.Range.Paragraphs
     
116.                     If .Count > 1 And Len(.Last.Range) = 2 Then .Last.Previous.Range.Characters.Last.Delete
     
117.                 End With
     
118.             Next
     
119. 
     
120.             '表头加粗
     
121.             .Cell(1, 1).Select
     
122.             With Selection
     
123.                 .SelectRow
     
124.                 With .Font
     
125.                     .NameFarEast = "黑体"
     
126.                     .Bold = True
     
127. '                    If Not ActiveDocument.Characters.Last.Font.Color = wdColorAutomatic Then
     
128.                     .Color = wdColorPink
     
129.                 End With
     
130.                 .Range.Find.Execute "[ 　^s^t]", , , 1, , , , , , "", 2
     
131.             End With
     
132. 
     
133.             .LeftPadding = CentimetersToPoints(0.19)
     
134.             .RightPadding = CentimetersToPoints(0.19)
     
135.             .AutoFitBehavior (wdAutoFitContent)
     
136.             .Select
     
137.             .AutoFitBehavior (wdAutoFitWindow)
     
138.         End With
     
139.         If a = 1 Then Exit Sub
     
140.     Next
     
141.     Selection.HomeKey Unit:=wdStory
     
142. End Sub
     
143. 
     
144. Sub TableDeleteBlankRows()
     
145. '表格删除空行
     
146.     Dim r As Row
     
147.     For Each r In Selection.Tables(1).Rows
     
148.         If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
     
149.     Next
     
150. End Sub

复制代码

wdpfox

有个对应的文档附件就更方便理解了。