[已解决]求一个身份证号码输入的VBA

kingdows

本人小白一个啊。不知道怎么写VBA 麻烦大神帮忙写一个，谢谢了。 身份证号码输入.rar (21.26 KB, 下载次数: 21)

2016-5-8 23:34 上传

点击文件名下载附件 http://www.excelpx.com/forum.php?mod=attachment&aid=Mzk2MDA0fDhjNTg4YzQ2OTVmZGNjZGFjMTIyM2RlNTk1NDZhYjg0fDE3MTQ3Mzc4NTU%3D&request=yes&_f=.rar

最佳答案

月排行榜 / 总排行榜

文刀天可

2016-5-9 12:44

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim theStr$, theLenth&, i&, theSum%, theNum%, a As Variant
   
3.     If Intersect(Target, Columns(4)) Is Nothing Then Exit Sub
   
4.     With Target
   
5.         If .Count > 1 Then Exit Sub
   
6.         If .Row < 12 Then Exit Sub
   
7.         theStr = .Value
   
8.         If theStr = "" Then Exit Sub
   
9.         theLenth = Len(theStr)
   
10.         If theLenth = 15 Or theLenth = 18 Then
    
11.             If theLenth = 18 Then
    
12.                 If IsNumeric(Left(theStr, theLenth - 1)) Then
    
13.                     a = VBA.Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
    
14.                     For i = 1 To theLenth - 1
    
15.                         theSum = theSum + CInt(Mid(theStr, i, 1)) * a(i - 1)
    
16.                     Next i
    
17.                     theNum = theSum Mod 11
    
18.                     a = VBA.Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2")
    
19.                     If UCase(Right(theStr, 1)) <> a(theNum) Then
    
20.                         MsgBox "校验码有误，请确认！", vbCritical, "错误"
    
21.                         .Item(1).Select
    
22.                         Application.SendKeys "{F2}"
    
23.                     End If
    
24.                 Else
    
25.                     MsgBox "非阿拉伯数字串，请确认！", vbCritical, "错误"
    
26.                     .Item(1).Select
    
27.                     Application.SendKeys "{F2}"
    
28.                 End If
    
29.             Else
    
30.                 If Not IsNumeric(theStr) Then
    
31.                     MsgBox "非阿拉伯数字串，请确认！", vbCritical, "错误"
    
32.                     .Item(1).Select
    
33.                     Application.SendKeys "{F2}"
    
34.                 End If
    
35.             End If
    
36.         Else
    
37.             MsgBox "身份证长度不正确，请确认！", vbCritical, "错误"
    
38.             .Item(1).Select
    
39.             Application.SendKeys "{F2}"
    
40.         End If
    
41.     End With
    
42. End Sub

复制代码

跳转到最佳答案楼层

wade_tan

这个网站中有的，搜索一下

文刀天可

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim theStr$, theLenth&, i&, theSum%, theNum%, a As Variant
   
3.     If Intersect(Target, Columns(4)) Is Nothing Then Exit Sub
   
4.     With Target
   
5.         If .Count > 1 Then Exit Sub
   
6.         If .Row < 12 Then Exit Sub
   
7.         theStr = .Value
   
8.         If theStr = "" Then Exit Sub
   
9.         theLenth = Len(theStr)
   
10.         If theLenth = 15 Or theLenth = 18 Then
    
11.             If theLenth = 18 Then
    
12.                 If IsNumeric(Left(theStr, theLenth - 1)) Then
    
13.                     a = VBA.Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
    
14.                     For i = 1 To theLenth - 1
    
15.                         theSum = theSum + CInt(Mid(theStr, i, 1)) * a(i - 1)
    
16.                     Next i
    
17.                     theNum = theSum Mod 11
    
18.                     a = VBA.Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2")
    
19.                     If UCase(Right(theStr, 1)) <> a(theNum) Then
    
20.                         MsgBox "校验码有误，请确认！", vbCritical, "错误"
    
21.                         .Item(1).Select
    
22.                         Application.SendKeys "{F2}"
    
23.                     End If
    
24.                 Else
    
25.                     MsgBox "非阿拉伯数字串，请确认！", vbCritical, "错误"
    
26.                     .Item(1).Select
    
27.                     Application.SendKeys "{F2}"
    
28.                 End If
    
29.             Else
    
30.                 If Not IsNumeric(theStr) Then
    
31.                     MsgBox "非阿拉伯数字串，请确认！", vbCritical, "错误"
    
32.                     .Item(1).Select
    
33.                     Application.SendKeys "{F2}"
    
34.                 End If
    
35.             End If
    
36.         Else
    
37.             MsgBox "身份证长度不正确，请确认！", vbCritical, "错误"
    
38.             .Item(1).Select
    
39.             Application.SendKeys "{F2}"
    
40.         End If
    
41.     End With
    
42. End Sub

复制代码

kingdows

哎呀，真的是谢谢大神了。。。

kingdows

文刀天可 发表于 2016-5-9 12:44

首先谢谢老师了，但有个问题啊。我的身份证号输入只要在D12至D15这四个单元格中输入，其他单元格（包括我那个表中兰色部分）还能输入文本或其他的数据，这个要怎么改啊。

文刀天可

kingdows 发表于 2016-5-9 19:09
首先谢谢老师了，但有个问题啊。我的身份证号输入只要在D12至D15这四个单元格中输入，其他单元格（包括我 ...

http://www.excelpx.com/thread-297776-1-1.html，可以参考下这个！

kingdows

文刀天可 发表于 2016-5-9 21:27
http://www.excelpx.com/thread-297776-1-1.html，可以参考下这个！

好的。谢谢了。