VB/VBA/VBScript根据出生日期计算年龄函数ComputeAge
提醒：本页面将不再更新、维护或者支持，文章、评论所叙述内容存在时效性，涉及技术细节或者软件使用方面不保证能够完全有效可操作，请谨慎参考！
有时需要处理一些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，好啦，说了这么多，函数在这里，用法注释已经写得详细了：
' ***************************************************
' *
' * 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或者有什么好的建议欢迎提出。