小编给大家介绍下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
复制代码就行了。