你所不了解的四个身份证信息提取工具（Excel的vba代码）

1、Sub 提取身份证出生日期()

        On Error Resume Next

    Dim ar, i, ii

    Dim tmp

 

    If Selection.Areas.Count > 1 Then Exit Sub

    If Selection.Cells.Count > Columns.Count Then

        MsgBox "您选择的区域过大！"

        Exit Sub

    End If

    ar = Selection

    Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)

   

    '一个单元格

    If Selection.Cells.Count = 1 Then

        tmp = IDBirthday(ar)

        ar = tmp

       

        rngs.Cells(1, 1) = ar

        Exit Sub

    End If

   

    '多个单元格

    Randomize Timer

    For i = 1 To UBound(ar)

        For ii = 1 To UBound(ar, 2)

            tmp = IDBirthday(ar(i, ii))

            ar(i, ii) = tmp

        Next

    Next

    rngs.Resize(UBound(ar), UBound(ar, 2)) = ar

End Sub

Function IDBirthday(sid) As String

    Dim rlt

    Select Case Len(sid)

        Case 15

            rlt = Format("19" & mid(sid, 7, 6), "0000-00-00")

        Case 18

            rlt = Format(mid(sid, 7, 8), "0000-00-00")

        Case 0

            rlt = ""

        Case Else

            rlt = "无效"

    End Select

    IDBirthday = rlt

End Function

2、Sub 提取身份证性别()

        On Error Resume Next

    Dim ar, i, ii

    Dim tmp

    If Selection.Areas.Count > 1 Then Exit Sub

    If Selection.Cells.Count > Columns.Count Then

        MsgBox "您选择的区域过大！"

        Exit Sub

    End If

    ar = Selection

    Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)

   

    '一个单元格

    If Selection.Cells.Count = 1 Then

        tmp = IDSex(ar)

        ar = tmp

       

        rngs.Cells(1, 1) = ar

        Exit Sub

    End If

   

    '多个单元格

    Randomize Timer

    For i = 1 To UBound(ar)

        For ii = 1 To UBound(ar, 2)

            tmp = IDSex(ar(i, ii))

            ar(i, ii) = tmp

        Next

    Next

    rngs.Resize(UBound(ar), UBound(ar, 2)) = ar

End Sub

Function IDSex(sid)

    Dim s As String

    Select Case Len(sid)

        Case 15

            s = Right(sid, 1)

        Case 18

            s = mid(sid, 17, 1)

        Case 0

            IDSex = ""

            Exit Function

        Case Else

            IDSex = "无效身份证号"

            Exit Function

    End Select

   

   

    If Int(s / 2) = s / 2 Then              '是否为偶数

        IDSex = "女"                          '如果是，则性别=女

    Else                                    '否则

        IDSex = "男"                          '性别=女

    End If

End Function                                '结束循环

3、Sub 提取身份证的年龄()

    On Error Resume Next

    Dim ar, i, ii

    Dim tmp

   

    If Selection.Areas.Count > 1 Then Exit Sub

    If Selection.Cells.Count > Columns.Count Then

        MsgBox "您选择的区域过大！"

        Exit Sub

    End If

    ar = Selection

    Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)

    '一个单元格

    If Selection.Cells.Count = 1 Then

        tmp = IDAge(ar)

        ar = tmp

        rngs.Cells(1, 1) = ar

        Exit Sub

    End If

    '多个单元格

    Randomize Timer

    For i = 1 To UBound(ar)

        For ii = 1 To UBound(ar, 2)

            tmp = IDAge(ar(i, ii))

            ar(i, ii) = tmp

        Next

    Next

    rngs.Resize(UBound(ar), UBound(ar, 2)) = ar

End Sub

Function IDAge(sid) As String

    Dim rlt As Date

    Select Case Len(sid)

        Case 15

            rlt = Format("19" & mid(sid, 7, 6), "0000-00-00")

        Case 18

            rlt = Format(mid(sid, 7, 8), "0000-00-00")

        Case 0

            IDAge = ""

            Exit Function

        Case Else

            IDAge = "无效"

            Exit Function

    End Select

    IDAge = Year(Date) - Year(rlt)

End Function

4、Sub 身份证验证真假()

    On Error Resume Next

    Dim ar, i, ii

    Dim tmp

   

    If Selection.Areas.Count > 1 Then Exit Sub

    If Selection.Cells.Count > Columns.Count Then

        MsgBox "您选择的区域过大！"

        Exit Sub

    End If

    ar = Selection

    Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)

   

    '一个单元格

    If Selection.Cells.Count = 1 Then

        tmp = CheckID(ar)

        ar = tmp

       

        rngs.Cells(1, 1) = ar

        Exit Sub

    End If

   

    '多个单元格

    Randomize Timer

    For i = 1 To UBound(ar)

        For ii = 1 To UBound(ar, 2)

            tmp = CheckID(ar(i, ii))

            ar(i, ii) = tmp

        Next

    Next

    rngs.Resize(UBound(ar), UBound(ar, 2)) = ar

End Sub

Public Function CheckID(ByVal ID18 As String) As String

        Dim rlt As String

        Dim Ai(17) As Integer

       

        Select Case Len(ID18)

            Case 15

                CheckID = "旧身份证号"

                Exit Function

            Case 18

           

            Case 0

                CheckID = ""

                Exit Function

            Case Else

                CheckID = "无效身份证号"

                Exit Function

        End Select

        CC = "10X98765432"

        Wi = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)

        s = 0

        For i = 0 To 16

            Ai(i) = CInt(mid(ID18, i + 1, 1))

            s = s + Ai(i) * Wi(i)

        Next i

        rlt = mid(CC, s Mod 11 + 1, 1)

       

        If Right(ID18, 1) = rlt Then

            CheckID = "真"

        Else

            CheckID = "假"

        End If

End Function

欢迎进去财税赋能群，如想加我我们请先加微信572042107

你所不了解的四个身份证信息提取工具（Excel的vba代码）