证书表格合并+证书自动编号 for Word2003VBA

413191246se · 发表于 2018-12-1 20:03

Sub 证书表格合并()
'更新/2018-11-28/TEST-OK/彻底定稿
If ActiveDocument.Saved = False Then MsgBox "未保存！", 0 + 16: End
Dim doc As Document, d$, a, b, n&, m&, q$, t As Table, c As Cell, r As Row, i&, s$, u$
Set doc = ActiveDocument
d = MsgBox("<是>：默认字段 <否>：表格一字段 <取消>：自定义", 3 + 48)
If d = vbYes Then
n = 1
m = 5
a = Array("证书编号", "课题", "姓名", "单位", "等级")
ElseIf d = vbNo Then
n = 2
Else
n = 3
q = InputBox("", "请输入自定义字段（空格分隔）！", "姓名单位课题等级证书编号")
If q = "" Then End
b = Split(q, " ")
m = UBound(b) + 1
End If
证书表格预置
If n = 2 Then m = doc.Tables(1).Columns.Count
With doc
For Each t In .Tables
With t
'调整字段
For i = 1 To m
If n = 1 Then
s = a(i - 1)
ElseIf n = 2 Then
s = doc.Tables(1).Rows(1).Cells(i).Range.Text
s = Left(s, Len(s) - 2)
ElseIf n = 3 Then
s = b(i - 1)
End If
If .Rows(1).Range Like "*" & s & "*" Then
.Rows(1).Select
With Selection
.Find.Execute s
If .Information(17) <> i Then
.Columns(1).Select
.Cut
t.Columns(i).Select
.Paste
End If
End With
Else
If i = 1 Then .Cell(1, 1).Select
With Selection
If i = 1 Then .InsertColumns Else .InsertColumnsRight
.Cells(1).Range.Text = s
End With
End If
Next i
'删除末列
If n = 1 Then
u = "等级"
ElseIf n = 2 Then
u = doc.Tables(1).Rows(1).Cells(doc.Tables(1).Columns.Count).Range.Text
u = Left(u, Len(u) - 2)
ElseIf n = 3 Then
u = b(UBound(b))
End If
Do While Not .Rows(1).Cells(.Columns.Count).Range Like u & "*"
.Columns(.Columns.Count).Delete
Loop
End With
Next
'合并数据
Do While .Tables.Count > 1
With .Tables(2)
.Rows(1).Delete
.Select
End With
With Selection
.MoveEnd 1, -1
.Cut
End With
.Tables(1).Range.Characters.Last.Select
With Selection
.MoveRight 12, 1
.Paste
End With
.Characters(1).Copy
Loop
End With
证书表格后期
End Sub
Sub 证书表格预置()
'更新/2018-11-28/TEST-OK/彻底定稿
Dim t As Table, c As Cell, r As Row, x&, y&, z&, j&, k&, e&
With ActiveDocument
With .Content.Find
.Execute "^13", , , , , , , , , "", 2
.Execute "^11", , , , , , , , , "", 2
End With
For Each t In .Tables
With t
'取消环绕
With .Rows
.WrapAroundText = False
.Alignment = wdAlignRowLeft
.LeftIndent = CentimetersToPoints(0)
End With
'是否规则(e=1=规则/e=0=不规则)
With .Range
x = .Information(wdEndOfRangeRowNumber)
y = .Information(wdEndOfRangeColumnNumber)
z = .Cells.Count
End With
If x <> 1 Then
If z = x * y Then
For k = 1 To y
For j = 1 To x - 1
If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
If e = 0 Then Exit For
Next j
If e = 0 Then Exit For
Next k
Else
e = 0
End If
Else
e = 1
End If
If e = 0 Then .Select: MsgBox "表格不规则！", 0 + 16: End
End With
Next
For Each t In .Tables
With t
'删除空格
.Select
Selection.MoveEnd
CommandBars.FindControl(ID:=122).Execute
'删除表头空格
With .Rows(1).Range.Find
.Execute "^w", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
End With
'规范字段
For Each c In .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 = "等级"
ElseIf .Text Like "*编号*" Then
.Text = "证书编号"
End If
If Len(.Text) = 2 Then .Text = "空列"
End With
Next
'删除空列
Do While .Rows(1).Range Like "*空列*"
.Rows(1).Select
With Selection
.Find.Execute "空列"
.Columns.Delete
End With
Loop
'删除序号
.Rows(1).Select
With Selection.Find
.Execute "序号"
If .Found = True Then .Parent.Columns.Delete
End With
'删除空行
For Each r In .Rows
If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
Next
'蓝色粉红
.Range.Font.Color = wdColorBlue
.Rows(2).Range.Font.Color = wdColorPink
End With
Next
End With
End Sub
Sub 证书表格后期()
'更新/2018-11-28/TEST-OK/彻底定稿
With ActiveDocument
If Not .Paragraphs(1).Range.Information(12) Then .Paragraphs(1).Range.Delete
.Range(Start:=.Tables(1).Range.End, End:=.Content.End).Delete
With .Tables(1).Rows(1).Range.Font
.Color = wdColorRed
.Bold = True
End With
With .Tables(1)
With .Range
.Font.Size = 10.5
.ParagraphFormat.Space1
End With
With .Rows
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0)
End With
.Select
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
End With
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
Selection.HomeKey 6
End With
End Sub

复制代码

413191246se · 发表于 2018-12-1 20:04

Sub 证书自动编号()
'更新/2018-11-28/TEST-OK/彻底定稿
If ActiveDocument.Tables.Count <> 1 Then MsgBox "证书数据源仅限一个表格！", 0 + 16: End
Dim doc As Document, t As Table, c As Cell, m&, n&, x&, k&, d&, b&
Set doc = ActiveDocument
Set t = doc.Tables(1)
证书表格预置
'字段
With t
For Each c In .Rows(1).Cells
With c.Range
If .Text Like "姓名*" Then
x = .Information(17)
ElseIf .Text Like "课题*" Then
k = .Information(17)
ElseIf .Text Like "等级*" Then
d = .Information(17)
ElseIf .Text Like "证书编号*" Then
b = .Information(17)
End If
End With
Next
If x = 0 Or k = 0 Then MsgBox "<姓名/课题>丢失！", 0 + 16: End
If d = 0 Then If MsgBox("<等级>丢失！是否继续？", 4 + 16) = vbNo Then End
If b = 0 Then If MsgBox("<证书编号>丢失！是否继续？", 4 + 16) = vbNo Then End
'编号
If b > 0 Then .Cell(2, b).Range.Select: 自动编号
m = .Rows.Count
'等级
If d > 0 Then
doc.Range(Start:=.Cell(2, d).Range.Start, End:=.Cell(m, d).Range.End).Select
For Each c In Selection.Cells
With c.Range
If Len(.Text) = 2 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf .Text Like "[1１一壹]*" Then
.Text = "一等"
ElseIf .Text Like "[2２二贰]*" Then
.Text = "二等"
ElseIf .Text Like "[3３三叁]*" Then
.Text = "三等"
End If
End With
Next
End If
'姓名
.Columns(x).Select
Selection.Find.Execute "[ 　^s]@", , , 1, , , , , , "", 2
doc.Range(Start:=.Cell(2, x).Range.Start, End:=.Cell(m, x).Range.End).Select
For Each c In Selection.Cells
With c.Range
.MoveEnd 1, -1
If Len(.Text) = 0 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf Len(.Text) = 1 Then
.Shading.BackgroundPatternColor = wdColorBrightGreen
ElseIf Len(.Text) = 2 Then
.Characters(1).InsertAfter Text:=" "
ElseIf Len(.Text) >= 4 Then
.Shading.BackgroundPatternColor = wdColorBrightGreen
End If
End With
Next
'课题
.Columns(k).Select
With Selection.Find
.Execute "《", , , , , , , , , "〈", 2
.Parent.SelectColumn
.Execute "》", , , , , , , , , "〉", 2
End With
doc.Range(Start:=.Cell(2, k).Range.Start, End:=.Cell(m, k).Range.End).Select
For Each c In Selection.Cells
With c.Range
.MoveEnd 1, -1
If Len(.Text) = 0 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf .Text Like "〈*〉" Then
.Characters.First.Delete
.Characters.Last.Delete
ElseIf .Text Like "〈*" Then
If Not (.Text Like "〈*〉?*") Then .Characters.First.Delete
ElseIf .Text Like "*〉" Then
If Not (.Text Like "*?〈*〉") Then .Characters.Last.Delete
ElseIf .Text Like "*?〈?*" Then
If Not (.Text Like "*〈*〉*") Then .Text = .Text & "〉"
ElseIf .Text Like "*?〉?*" Then
.Text = "〈" & .Text
End If
End With
Next
'序号
.Columns(1).Select
With Selection
.InsertColumns
.Shading.BackgroundPatternColor = wdColorAutomatic
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
For Each c In .Cells
c.Range.Text = n
n = n + 1
Next
.Cells(1).Range.Text = "序号"
End With
证书表格后期
'校验
' If b > 0 Then .Cell(2, b + 1).Select: 证书编号检查: 证书编号热键
End With
End Sub

复制代码

413191246se · 发表于 2018-12-1 20:05

附送：《表格处理》宏：

Sub 表格处理()
'更新/2018-11-28/TEST-OK/彻底定稿
Dim t As Table, c As Cell, a&, e&, i As Paragraph, j&, k&, x&, y&, z&
If Selection.Information(12) 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)
End With
'判断表格是否规则(e=1=规则/e=0=不规则)
With .Range
With .Find
.Execute "^13", , , , , , , , , "^p", 2
.Execute "^11", , , , , , , , , "^p", 2
End With
x = .Information(wdEndOfRangeRowNumber)
y = .Information(wdEndOfRangeColumnNumber)
z = .Cells.Count
End With
If x <> 1 Then
If z = x * y Then
For k = 1 To y
For j = 1 To x - 1
If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
If e = 0 Then Exit For
Next j
If e = 0 Then Exit For
Next k
Else
e = 0
End If
Else
e = 1
End If
'清除空格
If Asc(.Range.Next) <> 13 Then .Range.Next.InsertBefore Text:=vbCr
.Select
Selection.MoveEnd
CommandBars.FindControl(ID:=122).Execute
Selection.Characters.Last.Delete
.Select
'清除格式
Selection.ClearFormatting
With .Range
With .Font
.NameAscii = "Times New Roman"
.Size = 12
.Color = wdColorBlue
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
If e = 1 Then
'行高最小值
With .Rows
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0.9)
End With
'表头加粗
If Len(.Cell(2, 2).Range) > 2 Then
With .Rows(1).Range.Font
.NameFarEast = "黑体"
.Bold = True
.Color = wdColorRed
End With
End If
End If
'删除单元格空段
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
End With
If a = 1 Then Exit For
Next
End Sub

复制代码

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

[分享] 证书表格合并+证书自动编号 for Word2003VBA

评分