如何验证身份证号的正确性如果有误原始表中变为红色并将结果存入出错名单

yzyyyyyyy

输入身份证号时，有的输入的是15位，有的输入的是18位，无法通过校验上报。
规则
1、只要不是18位的就是错误（问题：不是18位）；
2、若是18位不能通过校验也是错误（问题：校验不过）
出现以上2个问题，原表相应的身份证号显示为红色，问题列显示出错问题（不是18位，校验不过）；
身份证出错名单表中生成如下内容

学号

年级

班级

序号

姓名

身份证号

问题

如何验证身份证号并生成出错名单.rar (7.26 KB, 下载次数: 151)

2012-9-20 11:30 上传

点击文件名下载附件

李兴德

如何验证18位的?

yangyangzhifeng

试试看

1. Function chk(ByVal sfzhm As String) As String
   
2.     Dim temp$, jyw
   
3.     temp = sfzhm
   
4.     If Len(temp) = 18 Then
   
5.         Dim i, ii, w, s, cs As Integer
   
6.         w = 1
   
7.         s = 0
   
8.         For i = 1 To 17
   
9.             ii = 18 - i
   
10.             w = (w * 2) Mod 11
    
11.             cs = Asc(Mid$(temp, 18 - i, 1)) - 48
    
12.             If cs >= 0 And cs < 10 Then
    
13.                 s = s + cs * w
    
14.             Else
    
15.                 chk = "第" & ii & "位,不是数字!"
    
16.                 i = 20
    
17.             End If
    
18.         Next
    
19.         If i = 18 Then
    
20.             s = (12 - s Mod 11) Mod 11
    
21.             jyw = LTrim$(str(s))
    
22.             If s = 10 Then
    
23.                 jyw = "X"
    
24.                 If Mid(sfzhm, 18, 1) = "X" Then chk = "正确！" Else chk = "错！末位应是:X"
    
25.             Else
    
26.                 If Mid(sfzhm, 18, 1) = jyw Then chk = "正确！" Else chk = "错！末位应是:" & jyw
    
27.             End If
    
28.         End If
    
29.     Else
    
30.         chk = "位数不对!"
    
31.     End If
    
32. End Function
    
33. Sub test()
    
34.     Dim ar, br, i&, j&, x&, rng As Range, str$
    
35.     ar = Sheet4.Range("a1").CurrentRegion
    
36.     ReDim br(1 To UBound(ar), 1 To 7)
    
37.     Sheet4.UsedRange.Offset(1).Font.ColorIndex = -4105
    
38.     For i = 2 To UBound(ar)
    
39.         str = chk(ar(i, 24))
    
40.         If str <> "正确！" Then
    
41.             x = x + 1
    
42.             For j = 1 To 5
    
43.                 br(x, j) = ar(i, j)
    
44.             Next
    
45.             br(x, 6) = ar(i, 24)
    
46.             br(x, 7) = str
    
47.             If rng Is Nothing Then Set rng = Sheet4.Range("x" & i) Else Set rng = Union(rng, Sheet4.Range("x" & i))
    
48.         End If
    
49.     Next
    
50.     If Not rng Is Nothing Then rng.Font.ColorIndex = 3
    
51.     Sheet1.UsedRange.Offset(1).ClearContents
    
52.     Sheet1.Range("f:f").NumberFormatLocal = "@"
    
53.     Sheet1.Range("a2").Resize(x, 7) = br
    
54. End Sub

复制代码

jokklx

1. Sub aa()
   
2. Dim i As Integer, j As Integer
   
3. For i = 2 To Sheets("zhd").Range("x65536").End(3).Row
   
4.     If Len(Trim(Sheets("zhd").Range("x" & i))) <> 18 Then
   
5.         Sheets("zhd").Range("z" & i) = "不是18位"
   
6.         Sheets("zhd").Range("x" & i).Interior.Color = RGB(255, 0, 0)
   
7.         For j = 1 To 5
   
8.             Sheets("身份证出错名单").Cells(65536, j).End(3).Offset(1, 0) = Sheets("zhd").Cells(i, j)
   
9.         Next
   
10.         Sheets("身份证出错名单").Range("f65536").End(3).Offset(1, 0) = Sheets("zhd").Range("x" & i)
    
11.         Sheets("身份证出错名单").Range("g65536").End(3).Offset(1, 0) = Sheets("zhd").Range("z" & i)
    
12.     End If
    
13.     If Len(Trim(Sheets("zhd").Range("x" & i))) = 18 And Trim(Sheets("zhd").Range("x" & i)) <> _
    
14.     zsfz(Left(Sheets("zhd").Range("x" & i), 6) & Mid(Sheets("zhd").Range("x" & i), 9, 9)) Then
    
15.         Sheets("zhd").Range("z" & i) = "校验不过"
    
16.         Sheets("zhd").Range("x" & i).Interior.Color = RGB(255, 0, 0)
    
17.    
    
18.     For j = 1 To 5
    
19.             Sheets("身份证出错名单").Cells(65536, j).End(3).Offset(1, 0) = Sheets("zhd").Cells(i, j)
    
20.         Next
    
21.         Sheets("身份证出错名单").Range("f65536").End(3).Offset(1, 0) = Sheets("zhd").Range("x" & i)
    
22.          Sheets("身份证出错名单").Range("g65536").End(3).Offset(1, 0) = Sheets("zhd").Range("z" & i)
    
23.         End If
    
24. Next
    
25. End Sub
    
26. Function zsfz(a15w As String) As String
    
27. Dim i As Integer
    
28. Dim b(1 To 17) As Integer
    
29. Dim a(1 To 18)
    
30. b(1) = 7
    
31. b(2) = 9
    
32. b(3) = 10
    
33. b(4) = 5
    
34. b(5) = 8
    
35. b(6) = 4
    
36. b(7) = 2
    
37. b(8) = 1
    
38. b(9) = 6
    
39. b(10) = 3
    
40. b(11) = 7
    
41. b(12) = 9
    
42. b(13) = 10
    
43. b(14) = 5
    
44. b(15) = 8
    
45. b(16) = 4
    
46. b(17) = 2
    
47. 
    
48. For i = 1 To 6
    
49. a(i) = Mid(a15w, i, 1)
    
50. Next
    
51. a(7) = 1
    
52. a(8) = 9
    
53. For i = 7 To 15
    
54. a(i + 2) = Mid(a15w, i, 1)
    
55. Next
    
56. For i = 1 To 17
    
57. Sum = Sum + a(i) * b(i)
    
58. Next
    
59. 
    
60. 
    
61. a(18) = Sum Mod 11
    
62. Select Case a(18)
    
63.     Case 0
    
64.     a(18) = 1
    
65.     Case 1
    
66.     a(18) = 0
    
67.     Case 2
    
68.     a(18) = "X"
    
69.     Case 3
    
70.     a(18) = 9
    
71.     Case 4
    
72.     a(18) = 8
    
73.     Case 5
    
74.     a(18) = 7
    
75.     Case 6
    
76.     a(18) = 6
    
77.     Case 7
    
78.     a(18) = 5
    
79.     Case 8
    
80.     a(18) = 4
    
81.     Case 9
    
82.     a(18) = 3
    
83.     Case 10
    
84.    a(18) = 2
    
85.    
    
86. End Select
    
87. For i = 1 To 18
    
88. zsfz = zsfz & a(i)
    
89. Next
    
90. End Function

复制代码

yzyyyyyyy

jokklx 发表于 2012-9-20 12:51

感谢上面两位大侠的出手相助

yangyangzhifeng

yzyyyyyyy 发表于 2012-9-20 15:08
感谢上面两位大侠的出手相助

短信收到，请测试

1. Function chk(ByVal sfzhm As String) As String
   
2.     Dim temp$, jyw
   
3.     temp = sfzhm
   
4.     If Len(temp) = 18 Then
   
5.         Dim i, ii, w, s, cs As Integer
   
6.         w = 1
   
7.         s = 0
   
8.         For i = 1 To 17
   
9.             ii = 18 - i
   
10.             w = (w * 2) Mod 11
    
11.             cs = Asc(Mid$(temp, 18 - i, 1)) - 48
    
12.             If cs >= 0 And cs < 10 Then
    
13.                 s = s + cs * w
    
14.             Else
    
15.                 chk = "第" & ii & "位,不是数字!"
    
16.                 i = 20
    
17.             End If
    
18.         Next
    
19.         If i = 18 Then
    
20.             s = (12 - s Mod 11) Mod 11
    
21.             jyw = LTrim$(str(s))
    
22.             If s = 10 Then
    
23.                 jyw = "X"
    
24.                 If Mid(sfzhm, 18, 1) = "X" Then chk = "正确！" Else chk = "错！末位应是:X"
    
25.             Else
    
26.                 If Mid(sfzhm, 18, 1) = jyw Then chk = "正确！" Else chk = "错！末位应是:" & jyw
    
27.             End If
    
28.         End If
    
29.     Else
    
30.         chk = "位数不对!"
    
31.     End If
    
32. End Function
    
33. Sub test()
    
34.     Dim ar, br, cr, i&, j&, x&, rng As Range, str$
    
35.     ar = Sheet4.Range("a1").CurrentRegion
    
36.     ReDim br(1 To UBound(ar), 1 To 7)
    
37.     ReDim cr(1 To UBound(ar), 1 To 1)
    
38.     Sheet4.UsedRange.Offset(1).Font.ColorIndex = -4105
    
39.     For i = 2 To UBound(ar)
    
40.         str = chk(ar(i, 24))
    
41.         If str <> "正确！" Then
    
42.             x = x + 1
    
43.             cr(i - 1, 1) = str
    
44.             For j = 1 To 5
    
45.                 br(x, j) = ar(i, j)
    
46.             Next
    
47.             br(x, 6) = ar(i, 24)
    
48.             br(x, 7) = str
    
49.             If rng Is Nothing Then Set rng = Sheet4.Range("x" & i) Else Set rng = Union(rng, Sheet4.Range("x" & i))
    
50.         End If
    
51.     Next
    
52.     If Not rng Is Nothing Then rng.Font.ColorIndex = 3
    
53.     Sheet1.UsedRange.Offset(1).ClearContents
    
54.     Sheet1.Range("f:f").NumberFormatLocal = "@"
    
55.     Sheet1.Range("a2").Resize(x, 7) = br
    
56.     Sheet4.Range("z2").Resize(UBound(cr)) = cr
    
57. End Sub

复制代码

yzyyyyyyy

jokklx 发表于 2012-9-20 12:51

感谢jokklx的热心帮助，贴出经jokklx修正的最终代码

1. Sub aa()
   
2. Dim i As Integer, j As Integer
   
3. Dim sum As Integer
   
4. For i = 2 To Sheets("zhd").Range("x65536").End(3).Row
   
5.     If Len(Trim(Sheets("zhd").Range("x" & i))) <> 18 Then
   
6.         Sheets("zhd").Range("z" & i) = "不是18位"
   
7.         Sheets("zhd").Range("x" & i).Interior.Color = RGB(255, 0, 0)
   
8.         Sheets("zhd").Range("a" & i & ":e" & i & ",x" & i & ",z" & i).Copy Sheets("身份证出错名单").Range("a65536").End(3).Offset(1, 0)
   
9.         GoTo xxx
   
10.     End If
    
11.     If Len(Trim(Sheets("zhd").Range("x" & i))) = 18 And zsfz(Trim(Sheets("zhd").Range("x" & i))) <> Trim(Sheets("zhd").Range("x" & i)) Then
    
12.         Sheets("zhd").Range("z" & i) = "校验不过"
    
13.         Sheets("zhd").Range("x" & i).Interior.Color = RGB(255, 0, 0)
    
14.         Sheets("zhd").Range("a" & i & ":e" & i & ",x" & i & ",z" & i).Copy Sheets("身份证出错名单").Range("a65536").End(3).Offset(1, 0)
    
15.         GoTo xxx
    
16.     End If
    
17. xxx:
    
18. Next
    
19. End Sub
    
20. Function zsfz(a17w As String) As String
    
21. Dim i As Integer
    
22. Dim a(1 To 18)
    
23. Dim b(1 To 17)
    
24. b(1) = 7
    
25. b(2) = 9
    
26. b(3) = 10
    
27. b(4) = 5
    
28. b(5) = 8
    
29. b(6) = 4
    
30. b(7) = 2
    
31. b(8) = 1
    
32. b(9) = 6
    
33. b(10) = 3
    
34. b(11) = 7
    
35. b(12) = 9
    
36. b(13) = 10
    
37. b(14) = 5
    
38. b(15) = 8
    
39. b(16) = 4
    
40. b(17) = 2
    
41. For i = 1 To 17
    
42. a(i) = Mid(a17w, i, 1)
    
43. sum = sum + a(i) * b(i)
    
44. Next
    
45. a(18) = sum Mod 11
    
46. Select Case a(18)
    
47.     Case 0
    
48.     a(18) = 1
    
49.     Case 1
    
50.     a(18) = 0
    
51.     Case 2
    
52.     a(18) = "X"
    
53.     Case 3
    
54.     a(18) = 9
    
55.     Case 4
    
56.     a(18) = 8
    
57.     Case 5
    
58.     a(18) = 7
    
59.     Case 6
    
60.     a(18) = 6
    
61.     Case 7
    
62.     a(18) = 5
    
63.     Case 8
    
64.     a(18) = 4
    
65.     Case 9
    
66.     a(18) = 3
    
67.     Case 10
    
68.    a(18) = 2
    
69.    
    
70. End Select
    
71. For i = 1 To 18
    
72. zsfz = zsfz & a(i)
    
73. Next
    
74. End Function
    
75. 
    

复制代码

zyhui1961

yzyyyyyyy 发表于 2012-9-21 16:22
感谢jokklx的热心帮助，贴出经jokklx修正的最终代码

420683030120199608
请帮忙验证一下，谢谢！

zyhui1961

jokklx 发表于 2012-9-20 12:51

420683030120199608
请帮忙验证一下，谢谢！

zyhui1961

yangyangzhifeng 发表于 2012-9-20 19:17
短信收到，请测试

420683030120199608
请帮忙验证一下，谢谢！