三种不规范日期转换为规范公文数字日期

413191246se

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

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

     
*  示例文本：（3in1包含大量空格）
2011年纪检监察工作计划

20  ２３  -   0７

20        １１ –          03  –           0  ２

二　〇二三年十二月二十　三日

二〇二三年0九月

2  ０２          3年１２月２３日

２０            2３年1  ０月

      
* 我的解决方案代码（日期预处理）：
* 我的通吃版代码竟然和 batmanbbs 的代码功能一样，但不如他的高级，也不是最终版。我要好好测测他的代码。

1. Sub aDate3in1()
   
2. '二〇二三年七月五日/2023-7-5/2023年7月5日(可能包含空格)/Update/TEST-OK/通吃版
   
3. 
   
4.     Const s As String = "[0-9０-９ 　^s^t一二三四五六七八九十零〇○Oo0０Ｏｏ]@"
   
5.     Const i As String = "[!0-9０-９ 　^s^t]"
   
6.     Dim t$
   
7. 
   
8.     With ActiveDocument.Content.Find
   
9.         .ClearFormatting
   
10.         .Text = "^13" & s & i & s & "*[^13^12]"
    
11.         .Forward = True
    
12.         .MatchWildcards = True
    
13.         Do While .Execute
    
14.             With .Parent
    
15.                 .Start = .Start + 1
    
16.                 .Select '****************************************
    
17.                 .Font.Color = wdColorPink '*****************************
    
18.                 If .Information(wdWithInTable) = False Then
    
19.                     t = .Text
    
20.                     t = Replace(t, " ", "")
    
21.                     t = Replace(t, "　", "")
    
22.                     t = Replace(t, ChrW(160), "")
    
23.                     t = Replace(t, vbTab, "")
    
24. 
    
25.                     If t Like "####[!0-9０-９]*" Then
    
26.                         .Text = t
    
27.                         .CharacterWidth = wdWidthHalfWidth
    
28. 
    
29.                         If .Text Like "*" & vbCr & vbCr Then .Characters.Last.Delete
    
30.                         If .Text Like "?????#[!0-9０-９]#?" Or .Text Like "?????#[!0-9０-９]##?" Then
    
31.                             .Characters(5).Text = "年"
    
32.                             .Characters(7).Text = "月"
    
33.                             .Characters.Last.InsertBefore Text:="日"
    
34.                         ElseIf .Text Like "?????##[!0-9０-９]#?" Or .Text Like "?????##[!0-9０-９]##?" Then
    
35.                             .Characters(5).Text = "年"
    
36.                             .Characters(8).Text = "月"
    
37.                             .Characters.Last.InsertBefore Text:="日"
    
38.                         ElseIf .Text Like "?????#?" Or .Text Like "?????##?" Then
    
39.                             .Characters(5).Text = "年"
    
40.                             .Characters.Last.InsertBefore Text:="月"
    
41.                         End If
    
42. 
    
43.                     ElseIf t Like "二???年*月*日?" Or t Like "二???年*月?" Then
    
44.                         t = Replace(t, "一", "1")
    
45.                         t = Replace(t, "二", "2")
    
46.                         t = Replace(t, "三", "3")
    
47.                         t = Replace(t, "四", "4")
    
48.                         t = Replace(t, "五", "5")
    
49.                         t = Replace(t, "六", "6")
    
50.                         t = Replace(t, "七", "7")
    
51.                         t = Replace(t, "八", "8")
    
52.                         t = Replace(t, "九", "9")
    
53.                         t = Replace(t, "零", "0")
    
54.                         t = Replace(t, "〇", "0")
    
55.                         t = Replace(t, "○", "0")
    
56.                         t = Replace(t, "O", "0")
    
57.                         t = Replace(t, "o", "0")
    
58.                         t = Replace(t, "0", "0")
    
59.                         t = Replace(t, "０", "0")
    
60.                         t = Replace(t, "Ｏ", "0")
    
61.                         t = Replace(t, "ｏ", "0")
    
62.                         .Text = t
    
63.                         If .Text Like "*年十#月*" Then .Characters(6).Text = "1"
    
64.                         If .Text Like "*月十#日*" Then .Text = Replace(.Text, "十", "1")
    
65.                         If .Text Like "*月#十#日*" Then .Text = Replace(.Text, "十", "")
    
66.                         If .Text Like "*年十月" & vbCr & "*" Then .Text = Replace(.Text, "十", "10")
    
67.                         Do While .Text Like "*" & vbCr & vbCr
    
68.                             .Text = Replace(.Text, vbCr, "")
    
69.                         Loop
    
70.                     End If
    
71. 
    
72.                     If .Text Like "*年0#月*" Then .Characters(6).Delete
    
73.                     If .Text Like "*年#月0#日*" Then .Characters(8).Delete
    
74.                     If .Text Like "*年##月0#日*" Then .Characters(9).Delete
    
75.                 End If
    
76.                 .Start = .End
    
77.                 .Start = .Start - 1
    
78.                 .Collapse
    
79.             End With
    
80.         Loop
    
81.     End With
    
82. End Sub

复制代码

vbee

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

batmanbbs

vbee 发表于 2023-7-5 14:14
笨办法也实用
2023年6月28日
2023年7月

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

413191246se

batmanbbs：你的函数是否针对我给的示例文本管用呢？
另：我想重新规划一下顺序（谁先谁后）；还有，6 个姨夫（IF）有点儿多，想精简为 3 个姨夫（IF）。

batmanbbs

413191246se 发表于 2023-7-6 09:26
batmanbbs：你的函数是否针对我给的示例文本管用呢？
另：我想重新规划一下顺序（谁先谁后）；还有，6 个 ...

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

413191246se

3Q! 删除所有空格可以做到，但一般不做。因为，表格中的内容可能需要空格。所以，只针对日期中的空格。我拟先将汉字日期转换为数字日期，再将“2023-7-6”这样的转换为数字日期，最后将“2023年7月6日”（可能含有空格）中的空格删除。然后，就可以查找标准的数字日期（绝对不含空格）了！

batmanbbs

1. Sub 规范日期()
   
2.     Dim arr(3) As String, i As Byte
   
3.     Dim defSpace$, defNumber$, defMark$, sDate$
   
4. 
   
5.     defSpace = " 　" & Chr(9) & ChrW(160)
   
6.     defNumber = "0-9０-９一二三四五六七八九十零〇○OoＯｏ"
   
7.     defMark = ChrW(&H2013) & "—-"    '注意：半角-需要放在最后
   
8.     arr(0) = "^13[" & defSpace & defNumber & "]@年[" & defSpace & defNumber & "]@月[^13^12]"
   
9.     arr(1) = "^13[" & defSpace & defNumber & "]@年[" & defSpace & defNumber & "]@月[" & defSpace & defNumber & "]@日[^13^12]"
   
10.     arr(2) = "^13[" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[^13^12]"
    
11.     arr(3) = "^13[" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[" & defMark & "][" & defSpace & defNumber & "]@[^13^12]"
    
12. 
    
13.     For i = 0 To UBound(arr)
    
14.         With ActiveDocument.Content.Find
    
15.             .ClearFormatting
    
16.             .Forward = True
    
17.             .MatchWildcards = True
    
18.             .Wrap = wdFindStop
    
19.             .Text = arr(i)
    
20.             Do While .Execute
    
21.                 With .Parent
    
22.                     .Start = .Start + 1: .End = .End - 1
    
23.                     sDate = 删除空白(.Text, defSpace)
    
24.                     If i > 1 Then sDate = 转换年月(sDate & IIf(i = 2, "月", "日"), defMark)
    
25.                     sDate = 日期转换(sDate)
    
26.                     If Len(sDate) = 0 Then .Font.ColorIndex = wdRed Else .Text = sDate
    
27.                     .Start = .End
    
28.                 End With
    
29.             Loop
    
30.         End With
    
31.     Next i
    
32. End Sub
    
33. 
    
34. Private Function 删除空白$(ByVal sDate$, ByVal ReplaceChar$)
    
35.     Dim i As Byte
    
36.     For i = 1 To Len(ReplaceChar)
    
37.         sDate = Replace(sDate, Mid(ReplaceChar, i, 1), "")
    
38.     Next i
    
39.     删除空白 = sDate
    
40. End Function
    
41. 
    
42. Private Function 转换年月$(ByVal sDate$, ByVal mark$)
    
43.     Dim i, j, pos, pos1 As Byte, s As String * 1
    
44.     For i = 1 To 2
    
45.         s = IIf(i = 1, "年", "月"): pos = 0
    
46.         If InStr(sDate, s) = 0 Then
    
47.             For j = 1 To Len(mark)
    
48.                 pos1 = InStr(sDate, Mid(mark, j, 1))
    
49.                 If pos1 > 0 Then pos = IIf(pos > pos1, pos1, IIf(pos = 0, pos1, pos))
    
50.             Next j
    
51.             If pos > 0 Then sDate = Left(sDate, pos - 1) & s & Mid(sDate, pos + 1)
    
52.         End If
    
53.     Next i
    
54.     转换年月 = sDate
    
55. End Function
    
56. 
    
57. Private Function 日期转换$(ByVal sDate$)
    
58.     Dim FindChar$, ReplaceChar$, i, pos As Byte
    
59.     FindChar = "０１２３４５６７８９零一二三四五六七八九〇○OoＯｏ"
    
60.     ReplaceChar = "01234567890123456789000000"
    
61. 
    
62.     sDate = Replace(sDate, "三十日", "30日")
    
63.     sDate = Replace(sDate, "二十日", "20日")
    
64.     sDate = Replace(sDate, "十日", "10日")
    
65.     sDate = Replace(sDate, "十月", "10月")
    
66.     sDate = Replace(sDate, "年十", "年1")
    
67.     sDate = Replace(sDate, "月十", "月1")
    
68.     sDate = Replace(sDate, "十", "")
    
69.     For i = 1 To Len(sDate)
    
70.         pos = InStr(FindChar, Mid(sDate, i, 1))
    
71.         If pos > 0 Then sDate = Replace(sDate, Mid(FindChar, pos, 1), Mid(ReplaceChar, pos, 1))
    
72.     Next i
    
73.     sDate = Replace(sDate, "年0", "年")
    
74.     sDate = Replace(sDate, "月0", "月")
    
75. 
    
76.     日期转换 = IIf(sDate Like "*[!0123456789年月日]*", "", sDate)
    
77. End Function

复制代码

413191246se

谢谢 batmanbbs 老师的代码！用示例文本测试，完全没有问题！辛苦了！（我对函数是一头雾水。）
你的“Quicker”公文自动排版程序（代码）可有分享下载？我们大家想分享试用。

batmanbbs

413191246se 发表于 2023-7-6 15:20
谢谢 batmanbbs 老师的代码！用示例文本测试，完全没有问题！辛苦了！（我对函数是一头雾水。）
你的“Qui ...

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

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

batmanbbs

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

函数和子程序其实是差不多，只不过函数需要返回值，和WORD对象的方法使用差不多。