ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[分享] 第一章(宏)2019-8-17 修正!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-8-17 13:49 | 显示全部楼层 |阅读模式
本帖最后由 413191246se 于 2019-8-17 19:56 编辑

* 不好意思! "楷体"在代码中是用 FontKT 表示的,但发布时没有带上函数,已经更正!请重新下载!
* 通过 Selection 对象查找“第X章”等特征字符,设置标题 1/2/3 三种级别(也适用于“第一条”/“第一部分”)。
* 本宏并非速度最快,拟用 Range 区域查找、ForEachNext 循环遍历段落法重新 VS,限于时间,稍后再做。
* 反复测试,确信没有问题,功能齐备,请各位朋友们试用(对有需要多级标题编号的朋友们是个福音!)。
  1. Sub 第一章()
  2. '更新/2019-8-17/定稿/Selection
  3.     Dim a$, b$, c$, d$, e$, f$, g$, h$, m&, i$, j$, k&, n&, s$, x&

  4.     a = MsgBox("<是>:第一章    <否>:第一条    <取消>:自定义    ", 3 + 48, "分类选择")
  5.     If a = vbYes Then
  6.         j = "章"
  7.     ElseIf a = vbNo Then
  8.         j = "条"
  9.     Else
  10.         j = InputBox("", "请输入量词(节/课/题/部分/阶段/自然段)", "部分")
  11.         If j = "" Then Exit Sub
  12.     End If

  13.     If MsgBox("<是>:第一" & j & "    <否>:第 1 " & j & "    ", 4 + 48, "数词选择") = vbYes Then
  14.         n = 2
  15.         e = "一"
  16.     Else
  17.         n = 1
  18.         e = "1"
  19.         f = " "
  20.     End If

  21.     If j = "条" Then
  22.         g = MsgBox("<是>:正文加粗    <否>:标题级别    ", 4 + 48, "样式选择")
  23.         If g = vbYes Then
  24.             h = MsgBox("<是>:黑体加粗    <否>:楷体加粗    <取消>:正文加粗    ", 3 + 48, "格式选择")
  25.             If h = vbYes Then
  26.                 m = 1
  27.                 c = "黑体加粗"
  28.             ElseIf h = vbNo Then
  29.                 m = 2
  30.                 c = "楷体加粗"
  31.             Else
  32.                 m = 3
  33.                 c = "正文加粗"
  34.             End If
  35.             GoTo sk
  36.         End If
  37.     End If

  38.     If m = 0 Then
  39.         b = MsgBox("<是>:标题 1    <否>:标题 2    <取消>:标题 3    ", 3 + 48, "级别选择")
  40.         If b = vbYes Then
  41.             s = 1
  42.             c = "标题 1"
  43.         ElseIf b = vbNo Then
  44.             s = 2
  45.             c = "标题 2"
  46.         Else
  47.             s = 3
  48.             c = "标题 3"
  49.         End If

  50.         If MsgBox("<是>:左对齐    <否>:居中    ", 4 + 48, "对齐选择") = vbYes Then
  51.             k = 0
  52.             d = "左对齐"
  53.         Else
  54.             k = 1
  55.             d = "居中"
  56.         End If
  57.     End If
  58. sk:
  59.     If MsgBox("请确认最终选择结果!是否继续?    ", 4 + 16, "第" & f & e & f & j & " / " & c & " / " & d) = vbNo Then Exit Sub

  60.     i = "^13第[一二三四五六七八九十百零〇○OoOo0-90-9]@" & j
  61. '''
  62.     With Selection
  63.         .HomeKey Unit:=wdStory
  64.         With .Find
  65.             .ClearFormatting
  66.             .Text = i
  67.             .Replacement.Text = ""
  68.             .Forward = True
  69.             .MatchWildcards = True
  70.             Do While .Execute
  71.                 With .Parent
  72.                     .MoveStart
  73.                     With .Paragraphs(1).Range
  74.                         With .Find
  75.                             .Execute "^w", , , , , , , , , "", 2
  76.                             .Execute " ", , , , , , , , , "", 2
  77.                         End With
  78.                         If .Text Like "*[。:;,、!?…—.:;,!?]?" Then .Characters.Last.Previous.Delete
  79.                         If m = 0 Then
  80.                             If s = 1 Then
  81.                                 .Style = wdStyleHeading1
  82.                             ElseIf s = 2 Then
  83.                                 .Style = wdStyleHeading2
  84.                                 .ParagraphFormat.SpaceBefore = 18
  85.                             Else
  86.                                 .Style = wdStyleHeading3
  87.                                 .ParagraphFormat.SpaceBefore = 18
  88.                             End If
  89.                             .Font.Color = wdColorRed
  90.                             With .ParagraphFormat
  91.                                 .SpaceAfter = 24
  92.                                 .KeepWithNext = False
  93.                                 .KeepTogether = False
  94.                             End With
  95.                             If k = 1 Then .ParagraphFormat.Alignment = wdAlignParagraphCenter
  96.                         End If
  97.                     End With
  98.                     .InsertAfter Text:=" "
  99.                     If .Next.Next.Next.Text = vbCr Then .Next.InsertAfter Text:=" "
  100.                     .MoveEnd 1, -1
  101.                     If m <> 0 Then
  102.                         If m = 1 Then
  103.                             .Font.NameFarEast = "黑体"
  104.                         ElseIf m = 2 Then
  105.                             .Font.NameFarEast = FontKT
  106.                         End If
  107.                         With .Font
  108.                             .Bold = True
  109.                             .Color = wdColorPink
  110.                         End With
  111.                     End If
  112.                     .MoveEnd 1, -Len(j)
  113.                     'AutoNum
  114.                     x = x + 1
  115.                     If n = 2 Then
  116.                         .Delete
  117.                         .Fields.Add Range:=.Range, Text:="= " & x & " \* CHINESENUM3"
  118.                         .HomeKey 5
  119.                         .Fields.Unlink
  120.                         .InsertBefore Text:="第"
  121.                     ElseIf n = 1 Then
  122.                         .MoveStart
  123.                         .Text = x
  124.                     End If
  125.                     .Start = .End
  126.                 End With
  127.             Loop
  128.         End With
  129.         .HomeKey Unit:=wdStory
  130.     End With
  131. End Sub
  132. Function FontKT() As String
  133.     If System.Version = 5.1 Then FontKT = "楷体_GB2312" Else FontKT = "楷体"
  134. End Function
复制代码


评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-8-17 19:49 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 413191246se 于 2019-8-17 19:57 编辑

略。。。。

TA的精华主题

TA的得分主题

发表于 2019-10-8 18:14 来自手机 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
这个宏好是好,但比较突出的问题是不合适公文排版,公文排版往往做为附件形式有几个不同附件,用这个第一章第一条就全部把序号给改了,造成公文内容错误

TA的精华主题

TA的得分主题

发表于 2019-12-21 08:50 | 显示全部楼层
您的代码很好,但有一个问题需要在代码中考虑。假如是对“第一章”这样的情况的格式进行调整,当它的位置是在文件的第一段,或者是在表格后的第一段时,这个代码无法变化格式

TA的精华主题

TA的得分主题

发表于 2019-12-21 10:48 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
可以在正式代码前用代码增加一个空段,并在所有表格后增加一段,在代码末尾再用代码删除。

=============================
Sub 后续处理()
    '文章首段前增加一个空段
    ActiveDocument.Content.InsertBefore Chr(13)
    '在所有表格后增加一段
    On Error Resume Next
    Dim Tbl As Table
    For Each Tbl In ActiveDocument.Tables
        Set tempRange = ActiveDocument.Range(Tbl.Range.End, Tbl.Range.End)
        tempRange.InsertAfter Chr(13)
    Next
   
   
    '*********此处放置正式代码**********
   
   
    '删除原本表格后增加的一段
    For Each Tbl In ActiveDocument.Tables
        Set tempRange = Tbl.Range
        tempRange.Collapse 0
        tempRange.Delete
    Next
    '删除文章首段前增加的空段
    If Len(ActiveDocument.Paragraphs(1).Range) < 2 Then ActiveDocument.Paragraphs(1).Range = Empty
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-28 23:04 , Processed in 0.057176 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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