VB/VBA/VBScript根据出生日期计算年龄函数ComputeAge

!本文可能 超过1年没有更新,今后内容也许不会被维护或者支持,部分内容可能具有时效性,涉及技术细节或者软件使用方面,本人不保证相应的兼容和可操作性。

有时需要处理一些Excel,这些Excel规定的日期格式是类似2012.02.26这样的形式,当我用到VBA或者VBScript处理这些日期时就很难识别并转换类似的日期格式。一般做法都是通过Split按点对其进行拆分。如果要求计算精确到年的话还好办,直接拿今年的年去减出生年就可以了,比如出生日期是1976.01,那么直接用今年2012 – 1976就得出按年算的年龄,有时可能会要求苛刻一点,比如说要求精确到月,呵呵,再Split,再判断,颇显麻烦,今天终于静下心来搞个统一的函数ComputeAge来处理这些问题,当然要能够识别我目前遇到的形如1972.01、1972.01.02、1972.1.2、72.01、72.01.02、19720102、197201日期格式,计算年龄嘛,我就让这个函数支持精确到日吧(可能用不上)。

单单是计算年龄,可能还不能满足我的胃口,当要统计类似1986年前出生的人的时候,我还要将1986转换一次,感觉麻烦,于是给ComputeAge添加了个比较时间的功能,比较的结果按照标准的-1、0、1进行返回。

比较特别的是这个函数还有个附加的功能就是把形如1972.01、1972.01.02、1972.1.2、72.01、72.01.02、19720102、197201日期格式转换为标准的脚本内置日期变量Date,好啦,说了这么多,函数在这里,用法注释已经写得详细了:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
' ***************************************************
' *
' * Description: 计算年龄
' * Author: wangye  <pcn88 at hotmail dot com>
' * Website: http://wangye.org
' *
' * Paramters:
' *    ByVal datetime    出生日期或者要比较的日期1
' *    ByVal curdatetime 要计算的间隔日期或者要比较的日期2
' *    ByVal grain       粒度,年龄计算或者日期比较粒度,分为:
' *            y   精确到年
' *            m   精确到月
' *            d   精确到日
' *            c   特殊标志,如果指定c,
' *                则表示将datetime转换标准日期变量
' *    ByVal comparetime  指示是计算datetime和curdatetime的间隔年龄
' *                       还是比较这两个时间(为True的时候)
' *                       当comparetime为True,那么
' *           datetime > curdatetime  返回 1
' *           datetime = curdatetime  返回 0
' *           datetime < curdatetime  返回 -1
' *
' * 可选项:
' *     curdatetime   默认为Now,计算机当前时间
' *     grain         默认为c,表示转换datetime
' *     comparetime   默认为False
' *
' * 返回值:
' *     当comparetime为False时返回由grain粒度控制的datetime和curdatetime
' *     时间间隔年龄,当comparetime为True时返回由grain粒度控制的
' *     datetime和curdatetime的大小-1 0 1(具体参考上面comparetime参数描述)
' *     当grain为c,表示仅转换datetime为脚本能够识别的合法日期变量。
' *     如果函数不能识别日期或者日期非法则返回vbObjectError+8(-2147221496)
' *
' * 备注:
' *     能够支持的日期格式有类似1972.01、1972.01.02、1972.1.2、72.01、72.01.02
' *     19720102、197201以及脚本能够控制的Date格式变量,可以通过
' *     IsDate函数判断为True的变量。
' *
' * 注意事项:
' *     日期不支持7201以及720102这样的格式,对于可能的错误格式
' *     会尝试按下面标准转换:
' *     761 => 1976.01    1976013 => 1976.01.03
' *     对于省略的月或者日,将按照1月或者1日看待,即1976将转换为1976-01-01
' *     1976.02将转换为1976.02.01
' *
' ***************************************************
Function ComputeAge( _
    ByVal datetime, _
    ByVal curdatetime, _
    ByVal grain, _
    ByVal comparetime)
 
    ComputeAge = vbObjectError+8
 
    Dim y,m,d,a
    datetime = Trim(datetime)
    If InStr(datetime, ".")>0 Then
        a = Split(datetime, ".")
        If UBound(a)=1 Then
            y = Trim(a(0))
            m = Trim(a(1))
        ElseIf UBound(a)=2 Then
            y = Trim(a(0))
            m = Trim(a(1))
            d = Trim(a(2))
        End If
    ElseIf IsDate(datetime) Then
        y = Year(datetime)
        m = Month(datetime)
        d = Day(datetime)
    ElseIf IsNumeric(datetime) Then
        y = CStr(CLng(datetime))
    Else
        Exit Function
    End If
 
    ' Fix long integer time format
    Select Case Len(y)
        Case 2
            y = "19" & y
        Case 3
            ' Possible incorrect format
            ' 761 => 1976.01
            m = Right(y, 1)
            y = "19" & Left(y, 1)
        Case 4
            ' Nothing to do
        Case 5
            ' Possible incorrect format
            ' 19761 => 1976.01
            m = Right(y, 1)
            y = Left(y, 4)
        Case 6
            ' 197601 => 1976.01
            m = Right(y, 2)
            y = Left(y, 4)
        Case 7
            ' Possible incorrect format
            ' 1976013 => 1976.01.03
            m = Mid(y, 5, 2)
            d = Right(y, 1)
            y = Left(y, 4)
        Case 8
            ' 19760103 => 1976.01.03
            m = Mid(y, 5, 2)
            d = Right(y, 2)
            y = Left(y, 4)
        Case Else
            Exit Function
    End Select
 
    If m="" Then m=1
    If d="" Then d=1
 
    y = CInt(y)
    m = CInt(m)
    d = CInt(d)
 
    If m<1 Or m>12 Then
        Exit Function
    End If
 
    If d<1 Or d>31 Then
        Exit Function
    End If
 
    datetime = y & "-" & Right("00" & m, 2) & _
            "-" & Right("00" & d, 2)
    If Not IsDate(datetime) Then Exit Function
    datetime = CDate(datetime)
 
    If  VarType(grain)<>vbString And _
        (Not IsNumeric(grain)) Then grain="c"
    If LCase(grain)="c" Then _
        ComputeAge = datetime : Exit Function
 
    If  VarType(curdatetime)=vbError Or _ 
        VarType(curdatetime)=vbEmpty Or _
        VarType(curdatetime)=vbNull Then
        curdatetime = Now()
    Else
        curdatetime = ComputeAge(curdatetime,,,False)
    End If
    If VarType(comparetime)<>vbBoolean Then _
            comparetime = False
 
    If Not IsDate(curdatetime) Then Exit Function
    curdatetime = CDate(curdatetime)
 
    If Not comparetime Then
        Select Case LCase(CStr(grain))
        Case "y","0"
            ComputeAge = DateDiff("yyyy", datetime, curdatetime)
        Case "m","1"
            ComputeAge = Int(DateDiff("m", datetime, curdatetime) / 12)
        Case "d","2"
            ComputeAge = Int(DateDiff("m", datetime, curdatetime) / 12)
            If m=Month(curdatetime) And d>Day(curdatetime) Then _
                    ComputeAge = ComputeAge-1
        End Select
    Else
        Select Case LCase(CStr(grain))
         Case "y","0"
            grain = "yyyy"
         Case "m","1"
            grain = "m"
         Case "d","2"
            grain = "d"
        End Select
        a = DateDiff(grain, curdatetime, datetime)
        If a>0 Then
            ComputeAge = 1
        ElseIf a<0 Then
            ComputeAge = -1
        Else
            ComputeAge = 0
        End If
    End If
End Function

我举几个使用的例子供大家参考吧:

WScript.Echo ComputeAge("19570321", Now, "y", False)
WScript.Echo ComputeAge("1957.3.21", Now, "y", False)
 
WScript.Echo ComputeAge("19570321", "2012", "y", False) ' 55
WScript.Echo ComputeAge("1957.3.21", "2012.01.03", "y", False) ' 55
WScript.Echo ComputeAge("1957.3.21", "2012.01.03", "m", False) ' 54
WScript.Echo ComputeAge("1957.3.21", "2012.03.22", "d", False) ' 55
WScript.Echo ComputeAge("1957.3.21", "2012.03.20", "d", False) ' 54
 
' Convert date to datetime variable
WScript.Echo ComputeAge("1957.3.21", , "c", False)
 
' Compare two date time by year, 1957 < 2001 return -1
WScript.Echo ComputeAge("1957.03.21", "2001.01.02", "y", True) ' -1
' Compare two date time by month, 1957.03 > 1957.02 return 1
WScript.Echo ComputeAge("1957.03.21", "1957.02", "m", True) ' 1
' Compare two date time by day, 1957.03.21 = 1957.03.21 return 0
WScript.Echo ComputeAge("1957.03.21", "1957.03.21", "d", True) ' 0
 
' Error occured "aaa" is not valid date time return vbObjectError+8
WScript.Echo ComputeAge("aaa", Now, "y", False) ' -2147221496

这段代码片段我已经放到github的gist上了,如果大家发现什么Bug或者有什么好的建议欢迎提出。

若无特别说明,本网站文章均为原创,原则上这些文章不允许转载,但是如果阁下是出于研究学习目的可以转载到阁下的个人博客或者主页,转载遵循创作共同性“署名-非商业性使用-相同方式共享”原则,请转载时注明作者出处谢绝商业性、非署名、采集站、垃圾站或者纯粹为了流量的转载。谢谢合作!
请稍后...

发表评论

电子邮件地址不会被公开。 必填项已用*标注