小编给大家介绍下WPS表格提取身份证号码中的各种信息
小编教程给大家带来的是一个相对比较强大的函数GetIDcardInfo，取得身份证号码中的各种信息：
这个函数的第一个参数为一个字符串，代表身份证号，第二个参数为整数，代表要获取的类型，具体为:
1 户口所在地(采用旧版数据库)
2 户口所在地(采用新版数据库)
3 生日
4 性别
5 年龄(考虑是否到达生日)
6 年龄(不考虑是否到达生日)
7 星座
返回值为相关信息。
好了，先看效果图吧:
接下来是代码：
'辅助函数CharInStr，判断char的首字符是不是在str中
Public Function CharInStr(ByVal char As String, ByVal str As String) As Integer
Application.ScreenUpdating=False '关闭屏幕更新，加快速度
On Error Resume Next
If Len(char)=0 Or Len(str)=0 Then
CharInStr=0: Exit Function '长度为零，退出
Else
char=Mid(char, 1, 1)
CharInStr=InStr(str, char)
End If
Application.ScreenUpdating=True '恢复屏幕更新
End Function
'辅助函数IsOkSFZID,，判断是否是合法的身份证号
Public Function IsOkSFZID(ByVal str As String) As Boolean
Application.ScreenUpdating=False '关闭屏幕更新，加快速度
On Error Resume Next
Dim Length As Integer
Length=Len(str)
If Length <> 15 And Length <> 18 Then
IsOkSFZID=False: Exit Function '长度不满足要求，返回假，退出
ElseIf Length=15 Then '15位必须纯数字
For i=1 To 15
If CharInStr(Mid(str, i, 1), "0123456789")=0 Then
IsOkSFZID=False: Exit Function '有非数字，返回假，退出
End If
Next i
ElseIf Length=18 Then '18位必须纯数字或者前17位纯数字，最后一位是大写或小写的X
For i=1 To 17
If CharInStr(Mid(str, i, 1), "0123456789")=0 Then
IsOkSFZID=False: Exit Function '有非数字，返回假，退出
End If
Next i
If CharInStr(Mid(str, 18, 1), "0123456789xX")=0 Then
IsOkSFZID=False: Exit Function '第18位不是数字或字母X(不分大小写)，返回假，退出
End If
End If
IsOkSFZID=True '能运行到这一步还没有退出函数的，说明符合要求，返回真
Application.ScreenUpdating=True '恢复屏幕更新
End Function
'======================
'主函数GetIDcardInfo，取得身份证号码中的各种信息
'GetType参数说明
'1 户口所在地(采用旧版数据库)
'2 户口所在地(采用新版数据库)
'3 生日
'4 性别
'5 年龄(考虑是否到达生日)
'6 年龄(不考虑是否到达生日)
'7 星座
Function GetIDcardInfo(str As Range, Optional GetType As Integer=2) As String
Application.ScreenUpdating=False '关闭屏幕更新，加快速度
On Error GoTo err '如果出现错误，自动跳到err段代码，只要是针对vlookup函数精确查找时没有找到结果会出错的情况
If False=IsOkSFZID(str) Then GetIDcardInfo="号码错误": Exit Function '号码不符合身份证号的格式，退出
If GetType > 7 Or GetType < 1 Then GetIDcardInfo="第二参数错误": Exit Function '第二参数越界，退出
Dim temp As String
'按第二参数处理各种情况
If GetType=1 Then
temp=WorksheetFunction.VLookup(Mid(str, 1, 2), ThisWorkbook.Sheets(1).Range("A1:B5805"), 2, False)
temp=temp & "-" & WorksheetFunction.VLookup(Mid(str, 1, 6), ThisWorkbook.Sheets(1).Range("A1:B5805"), 2, False)
GetIDcardInfo=temp
Exit Function
End If
If GetType=2 Then
temp=WorksheetFunction.VLookup(Val(Mid(str, 1, 6)), ThisWorkbook.Sheets(2).Range("A1:E3506"), 5, False)
GetIDcardInfo=temp
Exit Function
End If
'以上利用工作表函数VLookup进行精确查找，如果没有查找，将出错，此时将自动进入错误处理段代码
'处理出生日期和性别的代码
If GetType=3 Then
If Len(str)=15 Then
GetIDcardInfo="19" & Mid(str, 7, 2) & "-" & Mid(str, 9, 2) & "-" & Mid(str, 11, 2)
ElseIf Len(str)=18 Then
GetIDcardInfo=Mid(str, 7, 4) & "-" & Mid(str, 11, 2) & "-" & Mid(str, 13, 2)
End If
Exit Function
End If
If GetType=4 Then
GetIDcardInfo=VBA.IIf((Mid(str, 15, 3) Mod 2), "男", "女")
Exit Function
End If
'处理周岁 获得出生的年月日数据和当前计算机的年月日数据，并全部用val转换为数值，便于比较和计算
If GetType=5 Then
Dim y, m, d As Integer
If Len(str)=15 Then
y=Val("19" & Mid(str, 7, 2))
m=Val(Mid(str, 9, 2))
d=Val(Mid(str, 11, 2))
ElseIf Len(str)=18 Then
y=Val(Mid(str, 7, 4))
m=Val(Mid(str, 11, 2))
d=Val(Mid(str, 13, 2))
End If
If Val(Month(Now)) > m Then '当前月份大于出生月份，肯定已经过了生日
temp=Val(Year(Now)) - y
ElseIf Val(Month(Now))=m And Val(Day(Now)) >=d Then '当前月份和出生月份相等，而且当前日期不小于出生日期，说明正好是生日或者已经过了生日
temp=Val(Year(Now)) - y
Else '除此之外，没有到生日
temp=Val(Year(Now)) - y - 1
End If
GetIDcardInfo=temp
Exit Function
End If
If GetType=6 Then '不考虑生日因素时，直接年份相减求年龄
If Len(str)=15 Then
temp=Val(Year(Now)) - Val("19" & Mid(str, 7, 2))
ElseIf Len(str)=18 Then
temp=Val(Year(Now)) - Val(Mid(str, 7, 4))
End If
GetIDcardInfo=temp
Exit Function
End If
'处理星座
If GetType=7 Then
Dim XZ As Integer 'XZ=出生月*100+出生日，这样转为数值后容易判断和编程
If Len(str)=15 Then
XZ=Val(Mid(str, 9, 2)) * 100 + Val(Mid(str, 11, 2))
ElseIf Len(str)=18 Then
XZ=Val(Mid(str, 11, 2)) * 100 + Val(Mid(str, 13, 2))
End If
temp="号码错误"
Select Case XZ
Case 321 To 419
temp="白羊座"
Case 420 To 520
temp="金牛座"
Case 521 To 621
temp="双子座"
Case 622 To 722
temp="巨蟹座"
Case 723 To 822
temp="狮子座"
Case 823 To 922
temp="处女座"
Case 923 To 1023
temp="天秤座"
Case 1024 To 1122
temp="天蝎座"
Case 1123 To 1221
temp="射手座"
Case 1222 To 1231
temp="魔羯座"
Case 101 To 119
temp="魔羯座"
Case 120 To 218
temp="水瓶座"
Case 219 To 320
temp="双鱼座"
End Select
GetIDcardInfo=temp
Exit Function
End If
err: '错理处理
If GetType=1 Or GetType=2 Then
GetIDcardInfo="数据库中没有相关信息"
Else
GetIDcardInfo=""
End If
Application.ScreenUpdating=True '恢复屏幕更新
End Function
复制代码就行了。
