1、需求：
从身份证号里提取出出生日期、性别。
2、举例：
接着上一次的例子，表格汇总完成后，你又得到了一个任务，需要对表格的数据进行处理，需要增加出生日期、性别。
可是你一看表格，完了，没有收集出生日期、性别这些信息！
难道要重新收集一次？
3、代码实现
身份证编码是有规律的，只要知道了规律，我们就能够从中提取出自己所需要的数据。
baidu一下身份证编码规则就能知道，18位身份证规则：
- 前1、2位数字表示：所在省（直辖市、自治区）的代码；
- 第3、4位数字表示：所在地级市（自治州）的代码；
- 第5、6位数字表示：所在区（县、自治县、县级市）的代码；
- 第7-14位数字表示：出生年、月、日；
- 第15、16位数字表示：所在地的派出所的代码；
- 第17位数字表示性别：奇数表示男性，偶数表示女性；
- 第18位数字表示：校检码
15位身份证规则：
- 1-6与18位规则相同；
- 7-12位出数字表示：出生年、月、日；年份省略了19；
- 15位数字表示性别：奇数表示男性，偶数表示女性；
- 没有最后一位的校检码。
所以，按照这个规则，我们只要提取出对应位置的数据就可以了，性别判断取第15位或者17位数字，再取2的余数就能够判断出来：
代码语言：javascript复制Function GetGenderFromSFZ(strSFZ As String) As String
Dim i As Long
If VBA.Len(strSFZ) = 15 Then
i = VBA.CInt(VBA.Mid$(strSFZ, 15, 1))
ElseIf VBA.Len(strSFZ) = 18 Then
i = VBA.CInt(VBA.Mid$(strSFZ, 17, 1))
Else
GetGenderFromSFZ = ""
Exit Function
End If
'男的为奇数，女的为偶数
If i Mod 2 Then
GetGenderFromSFZ = "男"
Else
GetGenderFromSFZ = "女"
End If
End Function出生日期提取：
代码语言：javascript复制Function GetBirthrDayFromSFZ(strSFZ As String) As Date
If VBA.Len(strSFZ) = 15 Then
GetBirthrDayFromSFZ = VBA.DateSerial(VBA.CInt("19" & VBA.Mid$(strSFZ, 7, 2)), VBA.CInt(VBA.Mid$(strSFZ, 9, 2)), VBA.CInt(VBA.Mid$(strSFZ, 11, 2)))
ElseIf VBA.Len(strSFZ) = 18 Then
GetBirthrDayFromSFZ = VBA.DateSerial(VBA.CInt(VBA.Mid$(strSFZ, 7, 4)), VBA.CInt(VBA.Mid$(strSFZ, 11, 2)), VBA.CInt(VBA.Mid$(strSFZ, 13, 2)))
Else
GetBirthrDayFromSFZ = #12/31/9999#
End If
End Function校检码检验：
代码语言：javascript复制'校验码是根据前面十七位数字码，按照ISO 7064:1983.MOD 11-2校验码计算出来的检验码
' 1、将前面的身份证号码17位数分别乘以不同的系数。从第一位到第十七位的系数分别为：7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2 ；
' 2、将这17位数字和系数相乘的结果相加；
' 3、用加出来和除以11，看余数是多少；
' 4、余数0 1 2 3 4 5 6 7 8 9 10，分别对应1 0 X 9 8 7 6 5 4 3 2
Function CheckSFZ(strSFZ As String) As Boolean
Dim i As Long
Dim lSum As Long
Dim str As String
If VBA.Len(strSFZ) <> 18 Then
CheckSFZ = True
Exit Function
End If
For i = 1 To 17
lSum = lSum VBA.CLng(VBA.Mid(strSFZ, i, 1)) * (2 ^ (18 - i) Mod 11)
Next
str = VBA.Mid("10X98765432", lSum Mod 11 1, 1)
If str = VBA.Right(strSFZ, 1) Then
CheckSFZ = True
Else
CheckSFZ = False
End If
End Function主程序调用这3个函数就可以了，轻松增加出生日期、性别2列数据。
代码语言：javascript复制Enum RetCode
ErrRT = -1
SuccRT = 1
End Enum
Enum Pos
RowStart = 2
身份证号 = 4
KeyCol = 身份证号
Cols = 6
End Enum
Enum ResultEnum
出生日期
性别
Cols
End Enum
Type DataStruct
Src() As Variant
Rows As Long
Cols As Long
Result() As Variant
End Type
Sub vba_main()
Dim d As DataStruct
If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
If RetCode.ErrRT = GetResult(d) Then Exit Sub
End Sub
Private Function GetResult(d As DataStruct) As RetCode
ReDim d.Result(d.Rows - 1, ResultEnum.Cols - 1)
Dim i As Long
Dim strSFZ As String
d.Result(0, ResultEnum.出生日期) = "出生日期"
d.Result(0, ResultEnum.性别) = "性别"
For i = Pos.RowStart To d.Rows
strSFZ = VBA.CStr(d.Src(i, Pos.身份证号))
If CheckSFZ(strSFZ) Then
d.Result(i - 1, ResultEnum.出生日期) = GetBirthrDayFromSFZ(strSFZ)
d.Result(i - 1, ResultEnum.性别) = GetGenderFromSFZ(strSFZ)
Else
d.Result(i - 1, ResultEnum.出生日期) = "身份证号码有误"
End If
Next
Range("A1").Offset(0, Pos.Cols).Resize(d.Rows, ResultEnum.Cols).Value = d.Result
End Function
Private Function ReadSrc(d As DataStruct) As RetCode
ReadSrc = ReadData(d.Src, d.Rows, Pos.Cols, Pos.KeyCol, Pos.RowStart)
End Function
Private Function ReadData(ByRef RetArr() As Variant, ByRef RetRow As Long, Cols As Long, KeyCol As Long, RowStart As Long) As RetCode
ActiveSheet.AutoFilterMode = False
RetRow = Cells(Cells.Rows.Count, KeyCol).End(xlUp).Row
If RetRow < RowStart Then
MsgBox "没有数据"
ReadData = RetCode.ErrRT
Exit Function
End If
RetArr = Cells(1, 1).Resize(RetRow, Cols).Value
ReadData = RetCode.SuccRT
End Function模拟的几个校验基本都错误了！
