ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 三种不规范日期转换为规范公文数字日期

[复制链接]

TA的精华主题

TA的得分主题

发表于 2023-7-5 09:30 | 显示全部楼层 |阅读模式
本帖最后由 413191246se 于 2023-7-6 15:15 编辑

* 现在在公文中有的拟稿人仍遵循传统习惯,用汉字日期代替数字日期。按照公文标准,必须要将其转换为数字日期才规范。还有,在日常工作中,也有人简写为“2023-7-5”这样的日期。更有甚者,最近我发现竟然有人在公文数字日期中加上空格,如“2023年 6 月 2 8 日”这样的日期,致使公文排版中止。还有,公文中不止有一个单位落款和大标题。最近一周,我致力于解决此问题,但限于水平问题,进展缓慢,今天总算有所收获,继昨天我写了三个单独的程序后觉得废代码太多,遂今日合成为一个三合一(3in1)宏。
     

* 请各位朋友们指教、斧正,我也是用笨办法解决了问题。哪位朋友有更好更快的解决办法,请指正赐教。
* 谢谢 vbee 老师!请指教!帮我检查检查代码,能否更加简化。
* 值得注意的是:“〇”字可能有多种变体,如“零〇○Oo00Oo”等。

     
*  示例文本:(3in1包含大量空格)
2011年纪检监察工作计划
20  23  -   0
20        11 –          03  –           0  
二 二三年十二月二十 三日
二〇二三0
2  02          3年12月23日
20            23年1  

      
* 我的解决方案代码(日期预处理):
* 我的通吃版代码竟然和 batmanbbs 的代码功能一样,但不如他的高级,也不是最终版。我要好好测测他的代码。
  1. Sub aDate3in1()
  2. '二〇二三年七月五日/2023-7-5/2023年7月5日(可能包含空格)/Update/TEST-OK/通吃版

  3.     Const s As String = "[0-90-9  ^s^t一二三四五六七八九十零〇○Oo00Oo]@"
  4.     Const i As String = "[!0-90-9  ^s^t]"
  5.     Dim t$

  6.     With ActiveDocument.Content.Find
  7.         .ClearFormatting
  8.         .Text = "^13" & s & i & s & "*[^13^12]"
  9.         .Forward = True
  10.         .MatchWildcards = True
  11.         Do While .Execute
  12.             With .Parent
  13.                 .Start = .Start + 1
  14.                 .Select '****************************************
  15.                 .Font.Color = wdColorPink '*****************************
  16.                 If .Information(wdWithInTable) = False Then
  17.                     t = .Text
  18.                     t = Replace(t, " ", "")
  19.                     t = Replace(t, " ", "")
  20.                     t = Replace(t, ChrW(160), "")
  21.                     t = Replace(t, vbTab, "")

  22.                     If t Like "####[!0-90-9]*" Then
  23.                         .Text = t
  24.                         .CharacterWidth = wdWidthHalfWidth

  25.                         If .Text Like "*" & vbCr & vbCr Then .Characters.Last.Delete
  26.                         If .Text Like "?????#[!0-90-9]#?" Or .Text Like "?????#[!0-90-9]##?" Then
  27.                             .Characters(5).Text = "年"
  28.                             .Characters(7).Text = "月"
  29.                             .Characters.Last.InsertBefore Text:="日"
  30.                         ElseIf .Text Like "?????##[!0-90-9]#?" Or .Text Like "?????##[!0-90-9]##?" Then
  31.                             .Characters(5).Text = "年"
  32.                             .Characters(8).Text = "月"
  33.                             .Characters.Last.InsertBefore Text:="日"
  34.                         ElseIf .Text Like "?????#?" Or .Text Like "?????##?" Then
  35.                             .Characters(5).Text = "年"
  36.                             .Characters.Last.InsertBefore Text:="月"
  37.                         End If

  38.                     ElseIf t Like "二???年*月*日?" Or t Like "二???年*月?" Then
  39.                         t = Replace(t, "一", "1")
  40.                         t = Replace(t, "二", "2")
  41.                         t = Replace(t, "三", "3")
  42.                         t = Replace(t, "四", "4")
  43.                         t = Replace(t, "五", "5")
  44.                         t = Replace(t, "六", "6")
  45.                         t = Replace(t, "七", "7")
  46.                         t = Replace(t, "八", "8")
  47.                         t = Replace(t, "九", "9")
  48.                         t = Replace(t, "零", "0")
  49.                         t = Replace(t, "〇", "0")
  50.                         t = Replace(t, "○", "0")
  51.                         t = Replace(t, "O", "0")
  52.                         t = Replace(t, "o", "0")
  53.                         t = Replace(t, "0", "0")
  54.                         t = Replace(t, "0", "0")
  55.                         t = Replace(t, "O", "0")
  56.                         t = Replace(t, "o", "0")
  57.                         .Text = t
  58.                         If .Text Like "*年十#月*" Then .Characters(6).Text = "1"
  59.                         If .Text Like "*月十#日*" Then .Text = Replace(.Text, "十", "1")
  60.                         If .Text Like "*月#十#日*" Then .Text = Replace(.Text, "十", "")
  61.                         If .Text Like "*年十月" & vbCr & "*" Then .Text = Replace(.Text, "十", "10")
  62.                         Do While .Text Like "*" & vbCr & vbCr
  63.                             .Text = Replace(.Text, vbCr, "")
  64.                         Loop
  65.                     End If

  66.                     If .Text Like "*年0#月*" Then .Characters(6).Delete
  67.                     If .Text Like "*年#月0#日*" Then .Characters(8).Delete
  68.                     If .Text Like "*年##月0#日*" Then .Characters(9).Delete
  69.                 End If
  70.                 .Start = .End
  71.                 .Start = .Start - 1
  72.                 .Collapse
  73.             End With
  74.         Loop
  75.     End With
  76. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2023-7-5 14:14 | 显示全部楼层
本帖最后由 vbee 于 2023-7-5 14:28 编辑


笨办法也实用
2023年6月28日
2023年7月


GIF 2023-07-05 14-09-56.gif
705142735.png

TA的精华主题

TA的得分主题

发表于 2023-7-5 17:46 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
vbee 发表于 2023-7-5 14:14
笨办法也实用
2023年6月28日
2023年7月

对于11-19有BUG,根据VBEE老师的代码,改动了一下
image.png

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-7-6 09:26 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
batmanbbs:你的函数是否针对我给的示例文本管用呢?
另:我想重新规划一下顺序(谁先谁后);还有,6 个姨夫(IF)有点儿多,想精简为 3 个姨夫(IF)。

TA的精华主题

TA的得分主题

发表于 2023-7-6 10:29 | 显示全部楼层
413191246se 发表于 2023-7-6 09:26
batmanbbs:你的函数是否针对我给的示例文本管用呢?
另:我想重新规划一下顺序(谁先谁后);还有,6 个 ...

SORRY,我修改的代码只是针对VBEE老师提供的代码
对于老师你的需求,我的思路是:
1.删除所有空白(如果有些地方仍需空白,不好控制,可放在2后面操作)
2.提取符合条件的日期
3.if 不是年月日格式,修改成年月日格式
4.if 数字不是0-9,修改成####年##月##日(就是VBEE老师的代码,你自己的也没有问题)
5. 最后过滤 "年0" "月0" 这种情况

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-7-6 11:51 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
3Q! 删除所有空格可以做到,但一般不做。因为,表格中的内容可能需要空格。所以,只针对日期中的空格。我拟先将汉字日期转换为数字日期,再将“2023-7-6”这样的转换为数字日期,最后将“2023年7月6日”(可能含有空格)中的空格删除。然后,就可以查找标准的数字日期(绝对不含空格)了!

TA的精华主题

TA的得分主题

发表于 2023-7-6 13:54 | 显示全部楼层
  1. Sub 规范日期()
  2.     Dim arr(3) As String, i As Byte
  3.     Dim defSpace$, defNumber$, defMark$, sDate$

  4.     defSpace = "  " & Chr(9) & ChrW(160)
  5.     defNumber = "0-90-9一二三四五六七八九十零〇○OoOo"
  6.     defMark = ChrW(&H2013) & "—-"    '注意:半角-需要放在最后
  7.     arr(0) = "^13[" & defSpace & defNumber & "]@年[" & defSpace & defNumber & "]@月[^13^12]"
  8.     arr(1) = "^13[" & defSpace & defNumber & "]@年[" & defSpace & defNumber & "]@月[" & defSpace & defNumber & "]@日[^13^12]"
  9.     arr(2) = "^13[" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[^13^12]"
  10.     arr(3) = "^13[" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[^13^12]"

  11.     For i = 0 To UBound(arr)
  12.         With ActiveDocument.Content.Find
  13.             .ClearFormatting
  14.             .Forward = True
  15.             .MatchWildcards = True
  16.             .Wrap = wdFindStop
  17.             .Text = arr(i)
  18.             Do While .Execute
  19.                 With .Parent
  20.                     .Start = .Start + 1: .End = .End - 1
  21.                     sDate = 删除空白(.Text, defSpace)
  22.                     If i > 1 Then sDate = 转换年月(sDate & IIf(i = 2, "月", "日"), defMark)
  23.                     sDate = 日期转换(sDate)
  24.                     If Len(sDate) = 0 Then .Font.ColorIndex = wdRed Else .Text = sDate
  25.                     .Start = .End
  26.                 End With
  27.             Loop
  28.         End With
  29.     Next i
  30. End Sub

  31. Private Function 删除空白$(ByVal sDate$, ByVal ReplaceChar$)
  32.     Dim i As Byte
  33.     For i = 1 To Len(ReplaceChar)
  34.         sDate = Replace(sDate, Mid(ReplaceChar, i, 1), "")
  35.     Next i
  36.     删除空白 = sDate
  37. End Function

  38. Private Function 转换年月$(ByVal sDate$, ByVal mark$)
  39.     Dim i, j, pos, pos1 As Byte, s As String * 1
  40.     For i = 1 To 2
  41.         s = IIf(i = 1, "年", "月"): pos = 0
  42.         If InStr(sDate, s) = 0 Then
  43.             For j = 1 To Len(mark)
  44.                 pos1 = InStr(sDate, Mid(mark, j, 1))
  45.                 If pos1 > 0 Then pos = IIf(pos > pos1, pos1, IIf(pos = 0, pos1, pos))
  46.             Next j
  47.             If pos > 0 Then sDate = Left(sDate, pos - 1) & s & Mid(sDate, pos + 1)
  48.         End If
  49.     Next i
  50.     转换年月 = sDate
  51. End Function

  52. Private Function 日期转换$(ByVal sDate$)
  53.     Dim FindChar$, ReplaceChar$, i, pos As Byte
  54.     FindChar = "0123456789零一二三四五六七八九〇○OoOo"
  55.     ReplaceChar = "01234567890123456789000000"

  56.     sDate = Replace(sDate, "三十日", "30日")
  57.     sDate = Replace(sDate, "二十日", "20日")
  58.     sDate = Replace(sDate, "十日", "10日")
  59.     sDate = Replace(sDate, "十月", "10月")
  60.     sDate = Replace(sDate, "年十", "年1")
  61.     sDate = Replace(sDate, "月十", "月1")
  62.     sDate = Replace(sDate, "十", "")
  63.     For i = 1 To Len(sDate)
  64.         pos = InStr(FindChar, Mid(sDate, i, 1))
  65.         If pos > 0 Then sDate = Replace(sDate, Mid(FindChar, pos, 1), Mid(ReplaceChar, pos, 1))
  66.     Next i
  67.     sDate = Replace(sDate, "年0", "年")
  68.     sDate = Replace(sDate, "月0", "月")

  69.     日期转换 = IIf(sDate Like "*[!0123456789年月日]*", "", sDate)
  70. End Function
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2023-7-6 15:20 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
谢谢 batmanbbs 老师的代码!用示例文本测试,完全没有问题!辛苦了!(我对函数是一头雾水。)
你的“Quicker”公文自动排版程序(代码)可有分享下载?我们大家想分享试用。

TA的精华主题

TA的得分主题

发表于 2023-7-6 16:47 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
413191246se 发表于 2023-7-6 15:20
谢谢 batmanbbs 老师的代码!用示例文本测试,完全没有问题!辛苦了!(我对函数是一头雾水。)
你的“Qui ...

上面的第7句是可扩展的,可加入全角半角的点,斜杠等等

PS:本来我是很少推广我自己编写的动作的,就是自己用的。既然老师谈到了,可以到 https://getquicker.net/Sharedact ... mp;fromMyShare=true 安装。里面所有程序全部是公开的,可以通过打开动作文件,直接查看。

TA的精华主题

TA的得分主题

发表于 2023-7-6 17:59 | 显示全部楼层
本帖最后由 batmanbbs 于 2023-7-6 18:07 编辑

写函数是为了方便以后使用,三个函数都可以单独提出来给其他程序使用,特别是第一个去空白函数(不光删除空白,可用于删除多个字符)会经常用,写在一起通用性不强。

函数和子程序其实是差不多,只不过函数需要返回值,和WORD对象的方法使用差不多。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-7-18 06:26 , Processed in 0.054679 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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