ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2461|回复: 0

[原创] 证书自动编号(宏)& 证书调整行数(宏)[最终完美版]

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-7-24 13:57 | 显示全部楼层 |阅读模式
本帖最后由 413191246se 于 2015-7-24 14:13 编辑

* 证书数据源格式:Word2003表格,且表格数目必须只有一个!
* 证书字段:[姓名][课题][证书编号](3字段必须!),[等级][序号][单位](可有可无)。* 证书自动编号:有两种格式。一是纯数字(建议最好少于15位,否则会为为科学计数法),二是形如"ZD2015037",会自动向下编号。
* 邮件合并证书数据源后的合并结果文档,有的课题文字过多,达到3行或4行,需要折行,可以应用《证书调整行数》宏自动循环遍历每节,强制每节第2段落为2行(实际是减少字符缩放),然后打印。
**************《证书调整行数》(宏)代码如下:
Sub 证书调整行数()
    Dim i As Section
    For Each i In ActiveDocument.Sections
        i.Range.Paragraphs(2).Range.Select
        Do
            Selection.HomeKey Unit:=wdLine
            Selection.EndKey Unit:=wdLine
            Selection.MoveDown Unit:=wdLine, Count:=1
            If Asc(Selection) <> 13 Then
                Selection.Paragraphs(1).Range.Select
                Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2.35 '正文小一
                Selection.Font.Scaling = Selection.Font.Scaling - 5
            Else
                Exit Do
            End If
        Loop
    Next
End Sub
********《证书自动编号》(宏)最终完美版****代码如下:*****
Sub 证书自动编号()
'检查表格数目
    If ActiveDocument.Tables.Count <> 1 Then MsgBox "证书数据源仅允许有一个表格!", vbOKOnly + vbCritical, "证书自动编号": End

'删除换行符/回车符
    ActiveDocument.Content.Find.Execute findtext:="^l", ReplaceWith:="", Replace:=wdReplaceAll
    ActiveDocument.Content.Find.Execute findtext:="^13", ReplaceWith:="", Replace:=wdReplaceAll

'删除表外文字
    If ActiveDocument.Paragraphs(1).Range.Information(wdWithInTable) = False Then ActiveDocument.Paragraphs(1).Range.Delete
    ActiveDocument.Paragraphs.Last.Range.Delete

'删除段落首尾空格
    Selection.WholeStory
    CommandBars.FindControl(ID:=123).Execute
    CommandBars.FindControl(ID:=122).Execute

'声明变量
    Dim t As Table, c As Cell, r As Range, i As String, m As Long, n As Long, u As Column, lngName As Long, lngSubject As Long, lngGrade As Long, lngNum As Long, p As String, e As Long
    Set t = ActiveDocument.Tables(1)
    m = t.Rows.Count

'规范字段
    For Each c In t.Rows(1).Cells
        Set r = c.Range
        If r Like "*序*号*" Then
            r.Text = "序号"
        ElseIf r Like "*姓*名*" Then
            r.Text = "姓名"
        ElseIf r Like "*课*题*" Then
            r.Text = "课题"
        ElseIf r Like "*单*位*" Or r Like "*学*校*" Then
            r.Text = "单位"
        ElseIf r Like "*等*级*" Or r Like "*奖*项*" Then
            r.Text = "等级"
        ElseIf r Like "*编*号*" Then
            r.Text = "证书编号"
        End If
    Next

'检查字段
    For Each c In t.Rows(1).Cells
        Set r = c.Range
        If r Like "姓名*" Then
            lngName = lngName + 1
        ElseIf r Like "课题*" Then
            lngSubject = lngSubject + 1
        ElseIf r Like "等级*" Then
            lngGrade = lngGrade + 1
        ElseIf r Like "证书编号*" Then
            lngNum = lngNum + 1
        End If
    Next
    If (lngName = 1 And lngSubject = 1) And lngNum = 1 Then
        If lngGrade >= 2 Then MsgBox "[等级]字段过多!请检查!", vbOKOnly + vbCritical, "证书自动编号": End
        If lngGrade = 0 Then If MsgBox("[等级]字段不存在!是否继续?", vbYesNo + vbCritical, "证书自动编号") = vbNo Then End
    Else
        MsgBox "[姓名][课题][证书编号]字段不存在(或过多)!请检查!", vbOKOnly + vbCritical, "证书自动编号": End
    End If

'删除各列所有空格(课题列除外)
    For Each u In t.Columns
        If Not (u.Cells(1).Range Like "课题*") Then u.Select Else GoTo skipset
        Selection.Font.Color = wdColorBlue
        Selection.Find.Execute findtext:=" ", ReplaceWith:="", Replace:=wdReplaceAll
        Selection.SelectColumn
        Selection.Find.Execute findtext:="^w", ReplaceWith:="", Replace:=wdReplaceAll
skipset:
    Next

'证书编号<=15
    t.Rows(1).Select
    Selection.Find.Execute findtext:="证书编号"
    n = Selection.Information(wdStartOfRangeColumnNumber)
    t.Cell(2, n).Range.Select
    Selection.MoveEnd Unit:=wdCharacter, Count:=-1
    Selection.Range.CharacterWidth = wdWidthHalfWidth
    i = Selection.Text
    If Asc(i) = 13 Then
        If MsgBox("[证书编号]列没有初始编号!请选择!" & vbCr & vbCr & "是:在光标所在单元格中输入证书编号    否:不输入证书编号(继续)", vbYesNo + vbCritical, "证书自动编号") = vbYes Then End
    Else
        If IsNumeric(i) = False Then
            If Selection Like "[A-Z][A-Z]#######*" Then e = 0: p = Left(i, 2): i = Right(i, Len(i) - 2) Else MsgBox "证书编号不标准![纯数字]和[ZD2014357]格式可以自动编号!", vbOKOnly + vbCritical, "证书自动编号": End
        Else
            e = 1
        End If
        i = i + 1
        ActiveDocument.Range(Start:=t.Cell(3, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
        For Each c In Selection.Cells
            Set r = c.Range
            If e = 1 Then r.Text = i Else r.Text = p & i
            i = i + 1
        Next
    End If

'等级
    If lngGrade = 1 Then
        t.Rows(1).Select
        Selection.Find.Execute findtext:="等级"
        n = Selection.Information(wdStartOfRangeColumnNumber)
        ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
        For Each c In Selection.Cells
            Set r = c.Range
            r.MoveEnd Unit:=wdCharacter, Count:=-1
            If Len(r.Text) = 0 Then r.Shading.BackgroundPatternColor = wdColorRed
            If r Like "[11一壹]*" Then r.Text = "一等"
            If r Like "[22二贰]*" Then r.Text = "二等"
            If r Like "[33三叁]*" Then r.Text = "三等"
        Next
    End If

'姓名
    t.Rows(1).Select
    Selection.Find.Execute findtext:="姓名"
    n = Selection.Information(wdStartOfRangeColumnNumber)
    ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
    For Each c In Selection.Cells
        Set r = c.Range
        r.MoveEnd Unit:=wdCharacter, Count:=-1
        If Len(r.Text) = 0 Then
            r.Shading.BackgroundPatternColor = wdColorRed
        ElseIf Len(r.Text) = 1 Then
            r.Shading.BackgroundPatternColor = wdColorBrightGreen
        ElseIf Len(r.Text) = 2 Then
            r.Characters(1).InsertAfter Text:=Space(2)
        ElseIf Len(r.Text) >= 4 Then
            r.Shading.BackgroundPatternColor = wdColorBrightGreen
        End If
    Next

'课题
    t.Rows(1).Select
    Selection.Find.Execute findtext:="课题"
    n = Selection.Information(wdStartOfRangeColumnNumber)
    Selection.SelectColumn
    Selection.Font.Color = wdColorBlue
    Selection.Find.Execute findtext:="《", ReplaceWith:="〈", Replace:=wdReplaceAll
    Selection.SelectColumn
    Selection.Find.Execute findtext:="》", ReplaceWith:="〉", Replace:=wdReplaceAll
    ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
    For Each c In Selection.Cells
        Set r = c.Range
        r.MoveEnd Unit:=wdCharacter, Count:=-1
        If Len(r.Text) = 0 Then r.Shading.BackgroundPatternColor = wdColorRed
        If r.Characters(1) = "〈" And r.Characters.Last = "〉" Then r.Characters(1).Delete: r.Characters.Last.Delete
        If r.Characters(1) = "〈" Then
            r.Select
            Selection.Find.Execute findtext:="〉"
            If Selection.Find.Found = False Then r.Characters(1).Delete
        End If
        If r.Characters.Last = "〉" Then
            r.Select
            Selection.Find.Execute findtext:="〈"
            If Selection.Find.Found = False Then r.Characters.Last.Delete
        End If
    Next

'序号
    t.Rows(1).Select
    Selection.Find.Execute findtext:="序号"
    If Selection.Find.Found = True Then
        n = Selection.Information(wdStartOfRangeColumnNumber)
        ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Delete
        ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
        Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
            wdNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _
            wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
        Selection.ParagraphFormat.TabStops.ClearAll
        ActiveDocument.DefaultTabStop = CentimetersToPoints(0)
    End If
    t.Rows(1).Range.Font.Bold = True
    t.Rows(1).Range.Font.Color = wdColorAutomatic
    Selection.HomeKey Unit:=wdStory
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-1-16 00:20 , Processed in 0.039740 second(s), 7 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表