新手做的自定义函数，能校验18位身份证号码

starprotector

本人新手，前两天了解到身份证号码的校验规则，做了个自定义函数来校验

1. Function IDCard(ID As String, Optional CheckMode As Boolean = False)
   
2.     Dim i As Byte, a
   
3.     IDCard = 0
   
4.     a = Array(0, 7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
   
5. 
   
6.     If Len(ID) > 18 Or Len(ID) < 17 Or (CheckMode = False And Len(ID) = 17) Then
   
7.         IDCard = "位数有误！"
   
8.         Exit Function
   
9.     End If
   
10. 
    
11.     For i = 1 To 17
    
12.         IDCard = IDCard + Mid(ID, i, 1) * a(i)
    
13.     Next i
    
14.     IDCard = (12 - IDCard Mod 11) Mod 11
    
15.     If IDCard = 10 Then
    
16.         IDCard = "X"
    
17.     Else
    
18.         IDCard = IDCard & ""
    
19.     End If
    
20.    
    
21.     If CheckMode = False Then
    
22.         If IDCard = Right(ID, 1) Then
    
23.             IDCard = True
    
24.         Else
    
25.             IDCard = False
    
26.         End If
    
27.     End If
    
28. 
    
29. End Function

复制代码

我还做个了函数说明，不过好像只能在2010及以后应用

1. Sub IDCardDes()
   
2.     Dim ArgDes(1 To 2) As String
   
3.     ArgDes(1) = "18位身份证号码；计算校验码时可以只有前17位"
   
4.     ArgDes(2) = "校验模式，逻辑值 False(默认) 或 True。前者校验18位身份证号码，输出逻辑值校验结果；后者根据前17位号码计算第18位校验码"
   
5.     Application.MacroOptions Macro:="IDCard", _
   
6.             Description:="校验身份证号码（18位）", _
   
7.             Category:=14, _
   
8.             ArgumentDescriptions:=ArgDes()
   
9. End Sub

复制代码

效果展示：

上图是检验身份证号码是否能通过校验。

下图是根据前17位计算出第18位校验码

vitrel

楼主的是好东西，赞一个！
只可惜放在【原创】里，来寻宝的人较少，
别问我为什么知道，因为我也在【原创】里发过东西，待遇差不多，哈哈！

以前我录入员工的身份证号，怕录入错误，一般都是录入两次，然后自动进行比对的，
虽然出错的机会极少，但为图安心，还是要多做无用功。
现在有了您的自函，录入一次即可，真心觉得有用，收到了，谢谢！

starprotector

最近给进场人员登记信息时，有些人填写身份证号时，末尾的x输入的小写。
针对此问题，我增加了一个判别x的语句。

1. Function IDCard(ID As String, Optional CheckMode As Boolean = False)
   
2.     Dim i As Byte, a
   
3.     IDCard = 0
   
4.     a = Array(0, 7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
   
5.     If Len(ID) > 18 Or Len(ID) < 17 Or (CheckMode = False And Len(ID) = 17) Then
   
6.         IDCard = "位数有误！"
   
7.         Exit Function
   
8.     End If
   
9.     For i = 1 To 17
   
10.         IDCard = IDCard + Mid(ID, i, 1) * a(i)
    
11.     Next i
    
12.     IDCard = (12 - IDCard Mod 11) Mod 11
    
13.     If IDCard = 10 Then
    
14.         IDCard = "X"
    
15.     Else
    
16.         IDCard = IDCard & ""
    
17.     End If
    
18.    
    
19.     If CheckMode = False Then
    
20.         If IDCard = Right(ID, 1) Then
    
21.             IDCard = True
    
22.         Else
    
23.             If IDCard = "X" And Right(ID, 1) = "x" Then
    
24.                 IDCard = "X请大写！"
    
25.             Else
    
26.                 IDCard = False
    
27.             End If
    
28.         End If
    
29.     End If
    
30. End Function

复制代码

我有点强迫症，不喜欢末尾小写x，所以改成会提示“X请大写！”，觉得小写x无所谓的网友，可以将

1. IDCard = "X请大写！"

复制代码

改成

1. IDCard = True

复制代码

即可检核通过。


另外自定义函数的描述要生效，除了在模块里输入IDCardDes外，同时需要在ThisWorkbook里插入代码：

1. Private Sub Workbook_Open()
   
2.     IDCardDes
   
3.     ThisWorkbook.Saved = True '重置该文件为已保存（未修改）状态
   
4. End Sub

复制代码

starprotector

vitrel 发表于 2021-9-28 07:52
楼主的是好东西，赞一个！
只可惜放在【原创】里，来寻宝的人较少，
别问我为什么知道，因为我也在【原创 ...

在工作中发现末尾填写x的人不少，又增加了个判断语句。

vitrel

starprotector 发表于 2022-4-29 20:44
在工作中发现末尾填写x的人不少，又增加了个判断语句。

非常感谢您的热心提醒，这一点我之前确实没想到，确实有用。

starprotector

vitrel 发表于 2022-4-30 11:05
非常感谢您的热心提醒，这一点我之前确实没想到，确实有用。

能帮到就好，我论坛等级太低，好友还通过不了。等我升到初级吧。

jwjnh001

=OR(LEN(A2)=15,IF(LEN(A2)=18,MID("10X98765432",MOD(SUM(MID(A2,ROW(INDIRECT("1:17")),1)*2^(18-ROW(INDIRECT("1:17")))),11)+1,1)=RIGHT(A2)))一个公式三健搞定

vitrel

jwjnh001 发表于 2022-4-30 21:17
=OR(LEN(A2)=15,IF(LEN(A2)=18,MID("10X98765432",MOD(SUM(MID(A2,ROW(INDIRECT("1:17")),1)*2^(18-ROW(IND ...

朋友，非常感谢您的公式（代码）。
虽然校验的算法与楼主的有差异，
但所得的校验值，亲测是相同且正确的，
且胜在代码精简，非常实用，
再次感谢！！

OKJSJSF

奇怪，这几天都有朋友在弄身份证号？

Lovertdos

OKJSJSF 发表于 2022-5-1 17:38
奇怪，这几天都有朋友在弄身份证号？

太多人从上海回来，疫情防控升级了，手写的身份证号太多无法通过校验