1.增加了过程clearB()用来清除B1:Bx原有的出错说明，在过程examIdentityCard() 开头调用
2.修改了过程examIdentityCard()，如果身份证号码包含多余的字符则提示"包括多余字符；"
参加数据治理工作，使用库表转换功能把excel表格数据上传到平台上的数据库，在进行数据质量检测时，有许多身份证号码数据被检测为“非身份证号码”，但没有更具体的说明，比如是数据位数不对（应为15位或18位），出生日期不对（1986-02-30），或者是末位校验码不对……等等。
把这些包含被检测为“非身份证号码”的异常数据导出为Excel表格，再用VBA写代码来校验分析。
网上的关于检验身份证号码的代码很多，但基本不能拿来就用，还得结合自己的实际应用情况进行修改完善。
编写过程中的体会主要有两点：
一是对于18位身份证号码，末位的x可能被写成乘号×、全角大写x、全角小写x，而我们用的数据库系统数据质量检测只认大写半角X，写成号×、全角大写x、小写半角x都会被认为“非身份证号码”。这些都要进行预处理，将它们转换为大写半角X。预处理代码如下：
v = Rng.text
'检查是否包含×
If InStr(v, "×") > 0 Then
v = Replace(v, "×", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
'检查是否包含全角大写x
If InStr(v, "Ｘ") > 0 Then
v = Replace(v, "Ｘ", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
'检查是否包含全角小写x
If InStr(v, "ｘ") > 0 Then
v = Replace(v, "ｘ", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
二是身份证号码可能包含非打印字符，不做处理的话，就会影响Len()返回值，进而影响到身份证位数的判断。而在实际处理中，发现VBA提供的Trim()、Application.WorksheetFunction.Clean()都清理不干净，网上的代码也不适合我的情况，于是自己DIY了一个：
Function DelUnprintChar(s) As String
r = ""
For iPosition = 1 To Len(s) Step 1
c = Mid(s, iPosition, 1)
If ((c >= "0") And (c <= "9")) Or ((c >= "a") And (c <= "z")) Or ((c >= "A") And (c <= "Z")) Then
r = r & c
End If
Next
DelUnprintChar = r
End Function
完整的代码如下（身份证号码数据在A1:Ax，数据错误显示在B1:Bx）。：
Function exam18(v) As String
Dim cd1, r
r = ""
'下面检验出生日期是否正确
cd1 = Mid(v, 7, 4) & "-" & Mid(v, 11, 2) & "-" & Mid(v, 13, 2)
If Not IsDate(cd1) Then
r = "出身日期" & cd1 & "无效；"
Else
r = examIdentityCardLastDigit(v)
End If
exam18 = r
End Function
Function exam15(v) As String
'对15位身份证号码进行校验
Dim a, r
r = ""
'是否全数字
If Not IsNumeric(r) Then
r = "15位身份证号码应全是数字；"
Else
'下面检验出生日期是否正确
a = Mid(v, 7, 2) & "-" & Mid(v, 9, 2) & "-" & Mid(v, 11, 2)
If Not IsDate(a) Then
r = "出身日期" + a + "无效；"
End If
End If
exam15 = r
End Function
Function examIdentityCardLastDigit(v) As String
Dim i, arr1(), arr2(), r, s
arr1 = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2) '系数
arr2 = Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2") '对应的结果
r = ""
t = Left(v, 17)
If Not IsNumeric(t) Then
r = "身份证号码前17位应是数字；"
Else
s = 0
For i = 1 To 17
t = Mid(v, i, 1) '取出每位数
s = s + t * arr1(i - 1) '求和
Next i
s = s Mod 11 '取余数
t = Mid(v, 18, 1)
'If t = "x" Then
' t = "X"
'End If
If arr2(s) <> t Then '判断是否与最后一位相等
r = "末位数应为" & arr2(s) & "；"
End If
End If
examIdentityCardLastDigit = r
End Function
Function DelUnprintChar(s) As String
r = ""
For iPosition = 1 To Len(s) Step 1
c = Mid(s, iPosition, 1)
If ((c >= "0") And (c <= "9")) Or ((c >= "a") And (c <= "z")) Or ((c >= "A") And (c <= "Z")) Then
r = r & c
End If
Next
DelUnprintChar = r
End Function
Sub clearB()
'清除B1:Bx原有的出错说明
Range("b1", Cells(Rows.Count, "b").End(xlUp)).Clear
End Sub
Sub examIdentityCard()
Dim r, s, v
For Each Rng In Range("a1", Cells(Rows.Count, "a").End(xlUp))
v = Rng.text
'检查是否包含×
If InStr(v, "×") > 0 Then
v = Replace(v, "×", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
'检查是否包含全角大写x
If InStr(v, "Ｘ") > 0 Then
v = Replace(v, "Ｘ", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
'检查是否包含全角小写x
If InStr(v, "ｘ") > 0 Then
v = Replace(v, "ｘ", "X", 1, -1)
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "×应为X；"
End If
r = Len(v)
v = DelUnprintChar(v)
If Len(v) < r Then
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "包括多余字符；"
End If
If Len(v) = 15 Then
r = exam15(v)
If Len(r) <> 0 Then
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value + r
End If
ElseIf Len(v) = 18 Then
If InStr(v, "x") > 0 Then
v = UCase(v) '小写变大写
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value & "x应为X；"
End If
r = exam18(v)
If Len(r) <> 0 Then
Range("B" & Rng.Row).Value = Range("B" & Rng.Row).Value + r
End If
Else
Range("B" & Rng.Row).Value = "身份证位数应为15或18位；"
End If
Next
End Sub
