在Excel中检验身份证号

　　近几日，我的工作是录入更正的农业直补农户资料，涉及到了各包村干部上报的各种样式的报表，经会计清点后，由我来统一按上报的格式来摘抄到上报表中。据会计说，我的字写得还过得去，比小代强。

　　我建议用计算机来处理，打字比写字可快多了，还清楚。

　　下面的工作，就是录入一大堆的编号和身份证号以及姓名。姓名不是难事，在录入几十个后，我越发的想去上网，把读霸安装上，我打它来读，这样就不用抬头看屏幕了。想到乡里网吧的半个小时打开一封邮件的速度呀，我还是放弃了。

　　身份证可是不能再错误了，幸好我的电子书里有一段关于身份证格式的说明和程序，在稍加修改后，它已经可以用来批量的判断身份证是不是有格式（包括长度，出生年月，验证位）的错误。

　　本想通过数据有效性来作，只是公式里不能调用VBA的函数，真是郁闷。

 

　　下次有机会，改写一个公式来判断的。

 

 

Sub 检验选定区域身份证()
'
' 检验身份证 Macro
' 用于检测身份证号码是否正确
'
' 快捷键: Ctrl+q
'
Dim arange As range
Dim acell As range
Dim ret As Integer
Set arange = Selection
For Each acell In arange.Cells
  'MsgBox ActiveCell.Text
    ret = IDCheck(UCase(acell.Text))
    If ret <> 0 Then
        acell.Select
        MsgBox "请检查当前选定单元格的身份证是否正确", , "提示"
        Exit Sub
    End If
    
    
Next
    MsgBox "全部正确", , "提示"
End Sub
Function CurrentIdCheck() As Integer
Dim ret As Integer
'MsgBox ActiveCell.Text
'ret = IDCheck(ActiveCell.Text)
'MsgBox ret
'CurrentIdCheck = ret
CurrentIdCheck = 0
End Function
Function IDCheck(ByVal e As String) As Integer
 Dim arrVerifyCode
 Dim Wi
 Dim Checker
 Dim BirthDay
 IDCheck = 0 '验证通过时返回
 arrVerifyCode = Split("1,0,X,9,8,7,6,5,4,3,2", ",")
 Wi = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
 Checker = Split("1,9,8,7,6,5,4,3,2,1,1", ",")
 If Len(e) < 15 Or Len(e) = 16 Or Len(e) = 17 Or Len(e) > 18 Then
 'IDCheck= "身份证号必须是15位数或18位数！"
 IDCheck = 1
 Exit Function
 End If
 Dim Ai As String
 If Len(e) = 18 Then
 Ai = Mid(e, 1, 17)
 ElseIf Len(e) = 15 Then
 Ai = CStr(e)
 Ai = Left(Ai, 6) & "19" & Mid(Ai, 7, 9)
 End If
 If Not IsNumeric(Ai) Then
 'IDCheck= "身份证除最后一位外，必须为数字！"
 IDCheck = 2
 Exit Function
 End If
 Dim strYear As Integer
 Dim strMonth As Integer
 Dim strDay As Integer
 strYear = CInt(Mid(Ai, 7, 4))
 strMonth = CInt(Mid(Ai, 11, 2))
 strDay = CInt(Mid(Ai, 13, 2))
 BirthDay = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
 If IsDate(BirthDay) Then
 If DateDiff("yyyy", Now(), CDate(BirthDay)) < -140 Or CDate(BirthDay) > Now() Then
 'IDCheck= "身份证输入错误（日期输入错误）！"
 IDCheck = 3
 Exit Function
 End If
 If strMonth > 12 Or strDay > 31 Then
 'IDCheck= "身份证输入错误（日期输入错误）！"
 IDCheck = 3
 Exit Function
 End If
 Else
 'IDCheck= "身份证输入错误（日期输入错误）！"
 IDCheck = 3
 Exit Function
 End If
 Dim i As Integer
 Dim TotalmulAiWi As Integer
 For i = 0 To 16
 TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * CInt(Wi(i))
 Next
 Dim modValue As Integer
 modValue = TotalmulAiWi Mod 11
 Dim strVerifyCode ' As Object
 strVerifyCode = arrVerifyCode(modValue)
 Ai = Ai & strVerifyCode
 If Len(e) = 18 And CStr(e) <> Ai Then
 'IDCheck= "身份证号码输入错误（身份证包含有非法字符）！"
 IDCheck = 4
 Exit Function
 End If
 End Function