|
Private Sub Worksheet_Change(ByVal T As Range)
'限定作用域
On Error Resume Next
If Application.Intersect(T, Range("c2:c65536")) Is Nothing Or T.Value = "" Then Exit Sub
'限定身份证号是18位
If Len(T) <> 18 Then
Application.EnableEvents = False
MsgBox "身份证号不是18位,请重新输入"
T.Select
T.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'校验前17位是否为数字/检验第18位校验码是否正确
arr = Array("7", "9", "10", "5", "8", "4", "2", "1", "6", "3", "7", "9", "10", "5", "8", "4", "2")
brr = Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2")
For h = 1 To 17
j = Mid(T, h, 1)
If IsNumeric(j) = False Then
Application.EnableEvents = False
MsgBox "您可能输入了非法字符"
T.Select
T.ClearContents
Application.EnableEvents = True
Exit Sub
End If
s = s + j * arr(h - 1)
Next
k = s Mod 11
If Mid(T, 18) <> brr(k) Then
Application.EnableEvents = False
MsgBox "校验码不符,请重新输入"
T.Select
T.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Dim c As Range, Msg As String
If Target.Row = 1 Or Target = "" Then Exit Sub
If Target.Column = 7 Then
Set c = Range("G5:I" & Target.Row - 1).Find(Target, , , 1)
If Not c Is Nothing Then
Msg = MsgBox(Target & " 已于第 " & c.Row & " 列录入,确定录入?", vbInformation + vbYesNo)
If Msg = vbNo Then Target = ""
Else
Exit Sub
End If
ElseIf Target.Column = 4 Then
Set c = Range("C2:C" & Target.Row - 1).Find(Target, , , 1)
If Not c Is Nothing Then
Msg = MsgBox(Target & " 已于第 " & c.Row & " 列录入,确定录入?", vbInformation + vbYesNo)
If Msg = vbNo Then Target = ""
Else
Exit Sub
End If
End If
End Sub |
|