汉字数字与阿拉伯数字中文格式日期的转换

sylun · 发表于 2012-6-22 12:33

本帖最后由 sylun 于 2012-6-22 14:12 编辑

有感于近两天关于中文格式日期转换的帖子（http://club.excelhome.net/thread-484569-1-1.html），花了点时间写了一段转换代码。其基本思路是对查找到的特征文本，经简单筛选再结合Isdate函数的判断来确定有效日期格式文本，最后利用Quote域的日期图片开关来进行相应转换。通过编写这段代码，对Isdate和Datevalue等函数以及Quote域对中文日期的识别有了更多的了解。其适用范围见代码中的相关说明。
欢迎测试并提出改进意见。

Sub DateFormatConverting()
''有选定内容只处理选定部分，否则处理全文档
''如选定内容不超过一个段落，则不弹出对话框选择转换类型，程序将根据段落选定内容是否有阿拉伯数字来自动选择转换格式
''只转换含“年月日”、“年月”、“月日”或仅为“××××年”四种格式的有效日期文本
Dim myRange As Range
Dim a As Integer
Dim sz As String
Dim txt As String
Dim rq As String
Dim e As Long
Dim nf As String
Dim codetext As String
Dim switch As String
Dim n As Integer
With Selection
If .Type = wdSelectionNormal And .Paragraphs.Count = 1 Then
If .Text Like "*#*" Then a = 6 Else a = 7
If .Text Like "*[月日]" Then .End = .End + 1 '简单预防性措施
Else
a = MsgBox("转为汉字数字日期请按“是”，转为阿拉伯数字日期请按“否”", vbYesNoCancel, "汉字数字与阿拉伯数字中文日期格式转换")
End If
Set myRange = IIf(.Type = wdSelectionIP, ActiveDocument.Content, .Range)
End With
If a = 2 Then Exit Sub
sz = IIf(a = 6, "[0-9", "[〇○一二三四五六七八九十")
Application.ScreenUpdating = False
With myRange.Duplicate.Find
.Text = sz & "年月日]{4,}" '不想转换仅为“××××年”的格式文本时可用　.Text = sz & "]@[年月]" & sz & "月日]{2,}"
.MatchWildcards = True
Do While .Execute
With .Parent
If .Start >= myRange.End - 1 Then Exit Do
If .Text Like "*?[年月]*" Then
Do While .Text Like "*" & sz & "][年月日]" = False
.End = .End - 1
Loop
txt = Replace(.Text, "〇", "○")
If Mid(txt, 3, 1) = "年" Then
nf = DateValue(Left(txt, InStr(txt, "月")))
If a = 7 Then nf = IIf(nf Like "1*", "一九", "二○") Else nf = Empty
End If
If txt Like "????年" Then
txt = txt & IIf(a = 6, "1月", "一月")
switch = IIf(a = 6, " \@ EEEE年", " \@ yyyy年")
ElseIf a = 7 Then
switch = IIf(InStr(txt, "日"), IIf(InStr(txt, "年"), " \@ yyyy年M月d日", " \@ M月d日"), " \@ yyyy年M月")
Else
switch = IIf(InStr(txt, "日"), IIf(InStr(txt, "年"), " \@ EEEE年O月A日", " \@ O月A日"), " \@ EEEE年O月")
End If
rq = Mid(txt, InStr(txt, "月") + 1)
If Len(rq) = 3 Then
rq = Left(txt, InStr(txt, "月")) & Replace(rq, "十", "○")
ElseIf Len(rq) > 3 Then
rq = Left(txt, InStr(txt, "月")) & Replace(rq, "十", "")
Else
rq = txt
End If
If IsDate(rq) Then
codetext = Chr(34) & nf & IIf(InStr(txt, "年"), "", IIf(a = 7, "二〇一二年", "2012年")) & txt & Chr(34)
If nf <> Empty Then switch = Replace(switch, "yyyy年", "yy年")
With ActiveDocument.Fields.Add(.Duplicate, wdFieldQuote, codetext & switch, False)
e = Len(.Result.Text)
n = n + 1
.Unlink
End With
If Mid(txt, 3, 1) = "年" And a = 6 Then
ActiveDocument.Range(.Start, .Start + 2).Delete
e = e - 2
End If
.Start = .Start + e
nf = Empty
e = 0
End If
End If
End With
Loop
End With
If myRange.Paragraphs.Count > 1 Then MsgBox "OK！共转换了" & n & "个相关日期文本。"
Application.ScreenUpdating = True
End Sub

复制代码

嘉—嘉 · 发表于 2012-6-22 13:36

请问：这个怎么用啊？能不能上传一个附件呀？？

kqbt · 发表于 2012-6-22 13:25

代码包含了多种方法，考虑了方方面面。值得收藏学习！

守柔 · 发表于 2012-6-23 06:29

本帖最后由守柔于 2012-6-23 06:53 编辑

sylun兄的代码很好。
其中，Range.Duplicate 属性，Quote域对于日期的转换，就是很好的见证。
我未对代码进行测试，只是读了数遍代码，提几个建议：
1.就查找而言，使用Range.Duplicate固然很好地解决了这个动中取静的Range的问题，但 If .Start >= myRange.End - 1 Then Exit Do在每次查换中均需判断，是否必须这样进行？有没有考虑如果增设一个书签，在这个书签对象的Range中查找替换，是否也可以或者更合理一些？如果是这样，是不是其中的
With ActiveDocument.Fields.Add(.Duplicate, wdFieldQuote, codetext & switch, False)
                        e = Len(.Result.Text)
                        n = n + 1
                        .Unlink
                     End With
                     If Mid(txt, 3, 1) = "年" And a = 6 Then
                        ActiveDocument.Range(.Start, .Start + 2).Delete
                        e = e - 2
                     End If
                     .Start = .Start + e
可以更简捷一些，即针对rngFound进行Fields.Add，然后更改域结果，如：
Set rngField = rngFound.Fields.Add(rngFound, wdFieldQuote, Chr$(34) & "2012-5-12" & Chr$(34) & " \@ EEEE年O月A日", False).Result
....
rngField.Text = Mid$(rngField.Text, 3)
2.对于一个较好的代码，要考虑错误处理程序。
3.规范变量的命名很重要,它可以提高代码可读性.比如过程中的a,e等.有关变量命名的专门文档可搜索本论坛等.

sqhsqhli · 发表于 2012-6-23 19:53

本帖最后由 sqhsqhli 于 2012-6-23 20:27 编辑

学然后知不足，向楼主版主致敬.
测试遇到当两个以上日期连续出现时，不能转换。。。当然从文本内容上来说不大可能出现这样的情况

sylun · 发表于 2012-6-24 09:34

守柔发表于 2012-6-23 06:29
sylun兄的代码很好。
其中，Range.Duplicate 属性，Quote域对于日期的转换，就是很好的见证。
我未对代码 ...

谢谢老大关注与指导。我平时写的代码因行数不多，任务与方法都不算复杂，加上想偷点懒，通常只讲究一下逻辑层次，变量命名确欠规范，说明文字也不多。
其实，上面的代码有其局限性，对无效的中文日期格式文本的处理有不确定性，主要原因源于Quote域对其识别与转换上存在自以为是的情形。另外，因其有插入域与断开链接两个编辑运作，效率不算高。
以下代码尝试另一种思路，不借用Quote域，只用Isdate函数判别格式文本的有效性并进行相应转换，并兼顾程序的可读性。

Sub DateFormateConverting2()
''有选定内容只处理选定部分，否则处理全文档
''如选定内容不超过一个段落，则不弹出对话框选择转换类型，程序将根据段落选定内容是否有阿拉伯数字来自动选择转换格式
''只转换含“年月日”、“年月”、“月日”或仅为“××××年”四种格式的有效日期文本
Const strChinesenum As String = "○一二三四五六七八九"
Dim rngFind As Range
Dim IntResponse As Integer
Dim strFindnum As String
Dim strFoundtext As String
Dim strDatetext As String
Dim strChineselistnum(31) As String
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim strYmd(2) As String
Dim strConvertYmd(2) As String
On Error GoTo Exit_sub
For i = 0 To 31 '将0至31之间的中文序数赋值给数组
If i < 10 Then
strChineselistnum(i) = Mid(strChinesenum, i + 1, 1)
ElseIf i Mod 10 > 0 Then
strChineselistnum(i) = IIf(i < 20, "十", Mid(strChinesenum, Int(i / 10) + 1, 1) & "十") & Mid(strChinesenum, i Mod 10 + 1, 1)
Else
strChineselistnum(i) = IIf(i < 20, "十", Mid(strChinesenum, Int(i / 10) + 1, 1) & "十")
End If
Next
With Selection '确定查找处理区域及转换类型
If .Type = wdSelectionNormal And .Paragraphs.Count = 1 Then
IntResponse = IIf(.Text Like "*#*", 6, 7)
If .Text Like "*[月日]" Then .End = .End + 1 '普通预防性措施
Else
IntResponse = MsgBox("转为汉字数字日期请按“是”，转为阿拉伯数字日期请按“否”", vbYesNoCancel, "汉字数字与阿拉伯数字中文日期格式转换")
End If
Set rngFind = IIf(.Type = wdSelectionIP, ActiveDocument.Content, .Range)
End With
If IntResponse = 2 Then Exit Sub
strFindnum = IIf(IntResponse = 6, "[0-9", "[〇○一二三四五六七八九十")
Application.ScreenUpdating = False
With rngFind.Duplicate.Find '查找与处理
.Text = strFindnum & "年月日]{4,}" '不想转换仅为“××××年”的格式文本时可用　.Text = strFindnum & "]@[年月]" & strFindnum & "月日]{2,}"
.MatchWildcards = True
Do While .Execute
With .Parent
If .Text Like "*?[年月]*" Then
Do While .Text Like "*" & strFindnum & "][年月日]" = False
.End = .End - 1
Loop
strFoundtext = Replace(.Text, "〇", "○")
If InStr(strFoundtext, "年") Then strYmd(0) = Split(strFoundtext, "年")(0)
If InStr(strFoundtext, "月") > 0 Then strYmd(1) = Split(strFoundtext, "月")(0)
If InStr(strYmd(1), "年") > 0 Then strYmd(1) = Split(strYmd(1), "年")(1)
If InStr(strFoundtext, "日") > 0 Then strYmd(2) = Replace(Split(strFoundtext, "月")(1), "日", "")
If IntResponse = 6 Then '转为汉字数字格式
strDatetext = IIf(strYmd(0) <> "", Join(strYmd, "-"), "2012" & Join(strYmd, "-"))
If strDatetext Like "*--" And Len(strDatetext) = 6 Then strDatetext = Replace(strDatetext, "--", "-1") _
Else If strDatetext Like "*-" Then strDatetext = Left(strDatetext, Len(strDatetext) - 1)
If IsDate(strDatetext) Then
If strYmd(0) <> "" Then
For i = 1 To Len(strYmd(0))
strConvertYmd(0) = strConvertYmd(0) & strChineselistnum(Mid(strYmd(0), i, 1))
Next
strConvertYmd(0) = strConvertYmd(0) & "年"
End If
If strYmd(1) <> "" Then strConvertYmd(1) = strChineselistnum(strYmd(1)) & "月"
If strYmd(2) <> "" Then strConvertYmd(2) = strChineselistnum(strYmd(2)) & "日"
.Text = Join(strConvertYmd, "")
n = n + 1
End If
Else '转为阿拉伯数字格式
For i = 1 To Len(strYmd(0))
For j = 0 To 9
If Mid(strYmd(0), i, 1) = strChineselistnum(j) Then
strConvertYmd(0) = strConvertYmd(0) & j
Exit For
End If
Next
Next
If strYmd(0) <> "" Then strConvertYmd(0) = strConvertYmd(0) & "年"
For i = 1 To 2
For j = 0 To 31
If strYmd(i) = strChineselistnum(j) Then
strConvertYmd(i) = j & IIf(i = 1, "月", "日")
Exit For
End If
Next
Next
strDatetext = Join(strConvertYmd, "")
If strDatetext Like "????年" Then strDatetext = strDatetext & "1月"
If IsDate(strDatetext) Then
.Text = Join(strConvertYmd, "")
n = n + 1
End If
End If
End If
.SetRange .End, rngFind.End
strDatetext = ""
Erase strYmd
Erase strConvertYmd
End With
Loop
End With
If rngFind.Paragraphs.Count > 1 Then MsgBox "OK！共转换了" & n & "个相关日期文本。" _
Else If n = 0 Then MsgBox "找不到有效中文日期文本！", vbInformation
Application.ScreenUpdating = True
Exit Sub
Exit_sub:
MsgBox "程序发生意外，终止执行！"
End Sub

复制代码

sylun · 发表于 2012-6-24 09:48

sqhsqhli 发表于 2012-6-23 19:53
学然后知不足，向楼主版主致敬.
测试遇到当两个以上日期连续出现时，不能转换。。。当然从文本内容上来说 ...

谢谢sqhsqhli 兄关注。因这样的两个日期只成为一个匹配。要再区分应该也行，只是从实际文本中似难以出现。

sylun · 发表于 2012-6-24 10:06

嘉—嘉发表于 2012-6-22 13:36
请问：这个怎么用啊？能不能上传一个附件呀？？

如果不会用，上传附件也解决不了您的问题。建议在本版中查找一下如何将宏代码放入文档并运行宏，如http://club.excelhome.net/forum.php?mod=viewthread&tid=727438

嘉—嘉 · 发表于 2012-6-24 15:28

你好，我这里提示编译错误

xiaoxiaoyu · 发表于 2014-8-13 15:25

出现异常，请大家帮看看。系统为windows 8 +office 2013

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

[分享] 汉字数字与阿拉伯数字中文格式日期的转换