VBA从身份证号获取信息

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的余数就能够判断出来：

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

出生日期提取：

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

校检码检验：

'校验码是根据前面十七位数字码，按照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列数据。

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

模拟的几个校验基本都错误了！