林海波's blog

 以下代码用于校验指定列的身份证号码是否正确：
 

VBScript code复制代码

Private Sub IdcardCheck()
    
    Dim i, startIndex, strColumn, intColumn
    Dim sex, age, birthday

    strColumn = "A" '遍历的列号，检查第几列的数据？
    startIndex = 3 '开始位置,第几行开始？
    
    
    intColumn = ColumnNum(strColumn)
    For i = startIndex To UsedRange.Rows.Count
 
         If Not IdCheck(Cells(i, intColumn), sex, age, birthday) Then
         
             Range(Cells(i, 1), Cells(i, 1)).EntireRow.Select '选中行
             MsgBox "第" & strColumn & "列，第" & i & "行数据有误", 48, "提示："

         End If
    Next
End Sub

'把参数指定的字符列（A～XFD）转换为10进制的列号（1～16384），大小写均可
Public Function ColumnNum(ByVal a) As Long
    Dim r
    r = 0
    If VarType(a) = vbString And Len(a) > 0 Then
        a = UCase(a)
        r = Asc(Left(a, 1)) - Asc("A") + 1
        If Len(a) >= 2 Then
            r = r * 26 + Asc(Mid(a, 2, 1)) - Asc("A") + 1
            If Len(a) >= 3 Then
                r = r * 26 + Asc(Mid(a, 3, 1)) - Asc("A") + 1
            End If
        End If
    End If
    ColumnNum = r
End Function


'身份证校验算法,返回布尔值代表是否正确，参数1:身份证号码，其余参数返回 性别、年龄、生日
'Debug.Print "", sex, age, birthday
Function IdCheck(ByVal s, ByRef sex, ByRef age, ByRef birthday) As Boolean
    Dim code1, code2, i As Integer, n As Integer, temp As String
    code1 = Split("1 0 X 9 8 7 6 5 4 3 2")
    code2 = Split("7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2 1")
    s = UCase(Trim(s))
    If Len(s) = 15 Then
        temp = Mid(s, 1, 6) & "19" & Mid(s, 7)
    ElseIf Len(s) = 18 Then
        temp = Left(s, 17)
    Else
        Exit Function
    End If
    For i = 0 To Len(temp) - 1
        n = n + Mid(temp, i + 1, 1) * code2(i)
    Next
    n = n Mod 11
    If Len(s) = 18 And code1(n) <> Right(s, 1) Then Exit Function
    IdCheck = True
    If Len(s) = 15 Then
        birthday = Format("19" & Mid(s, 7, 6), "#0000-00-00")
        age = Year(Date) - Year(CDate(birthday)) + 1
        sex = IIf(Right(s, 1) Mod 2 = 1, "男", "女")
    Else
        birthday = Format(Mid(s, 7, 8), "#0000-00-00")
        age = Year(Date) - Year(CDate(birthday)) + 1
        sex = IIf(Mid(s, 17, 1) Mod 2 = 1, "男", "女")
    End If
End Function