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

413191246se · 发表于 2024-1-13 00:52

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

Sub CertificateTablesMerge()
'证书表格合并
Dim t As Table, c As Cell, arr, i&, oRow&, oCol&, xRow&
arr = Split("证书编号/课题/姓名/单位/等级", "/")
With ActiveDocument
For Each t In .Tables
t.Rows.WrapAroundText = False
For Each c In t.Rows(1).Cells
With c.Range
If .Text Like "*编*号*" Then
.Text = "证书编号"
ElseIf .Text Like "*[课题]*[题目]*" Then
.Text = "课题"
ElseIf .Text Like "*姓*名*" Then
.Text = "姓名"
ElseIf .Text Like "*[单学]*[位校]*" Then
.Text = "单位"
ElseIf .Text Like "*[等奖]*[级项次]*" Then
.Text = "等级"
End If
End With
Next
Next
If Not .Characters(1).Information(12) Then .Range(0, .Tables(1).Range.Start).Delete
If Not .Characters(1).Information(12) Then .Range(0, .Tables(1).Range.Start).Delete
Selection.HomeKey 6
Selection.SplitTable
.Tables.Add .Range(0, 0), 2, 5, 1
Set t = .Tables(1)
With t.Rows(1)
For i = 0 To UBound(arr)
.Cells(i + 1).Range.Text = arr(i)
Next
End With
Do While .Tables.Count > 1
xRow = t.Range.Information(wdMaximumNumberOfRows)
For i = 0 To UBound(arr)
For Each c In .Tables(2).Rows(1).Cells
If c.Range.Text Like arr(i) & "*" Then
c.Select
With Selection
oCol = .Information(wdEndOfRangeColumnNumber)
oRow = .Information(wdMaximumNumberOfRows)
ActiveDocument.Range(Start:=.Tables(1).Cell(2, oCol).Range.Start, _
End:=.Tables(1).Cell(oRow, oCol).Range.End).Select
.Cut
t.Cell(xRow, i + 1).Range.Select
.HomeKey
.Paste
End With
End If
Next
Next
.Tables(2).Delete
t.Select
Selection.InsertRowsBelow 1
Loop
.Range(Start:=t.Range.End, End:=.Content.End).Delete
End With
TableProcess
TableDeleteBlankRows
End Sub
Sub TableProcess()
'表格处理
Dim t As Table, c As Cell, i As Paragraph, a&
If Selection.Information(wdWithInTable) = True Then a = 1
For Each t In ActiveDocument.Tables
If a = 1 Then Set t = Selection.Tables(1)
With t
'取消环绕/左对齐/左缩进
With .Rows
.WrapAroundText = False
.Alignment = wdAlignRowLeft
.LeftIndent = CentimetersToPoints(0)
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0.9)
End With
'清除格式
With .Range
.Next.InsertParagraphBefore
.MoveEnd
.Select
Selection.ClearFormatting
CommandBars.FindControl(ID:=122).Execute
.MoveEnd 1, -1
.Next.Delete
With .Font
' If Not ActiveDocument.Characters.Last.Font.Color = wdColorAutomatic Then
.Color = wdColorBlue
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
'删除空段
For Each c In .Range.Cells
For Each i In c.Range.Paragraphs
If Asc(i.Range) = 13 And Len(i.Range) = 1 Then i.Range.Delete
Next
With c.Range.Paragraphs
If .Count > 1 And Len(.Last.Range) = 2 Then .Last.Previous.Range.Characters.Last.Delete
End With
Next
'表头加粗
.Cell(1, 1).Select
With Selection
.SelectRow
With .Font
.NameFarEast = "黑体"
.Bold = True
' If Not ActiveDocument.Characters.Last.Font.Color = wdColorAutomatic Then
.Color = wdColorPink
End With
.Range.Find.Execute "[ 　^s^t]", , , 1, , , , , , "", 2
End With
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
End With
If a = 1 Then Exit Sub
Next
Selection.HomeKey Unit:=wdStory
End Sub
Sub TableDeleteBlankRows()
'表格删除空行
Dim r As Row
For Each r In Selection.Tables(1).Rows
If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
Next
End Sub

复制代码

wdpfox · 发表于 2024-2-22 13:30

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

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

[分享] 证书表格合并（宏）更新！