EXCEL VBA 身份證檢查

1 工具 / 巨集 / VB編輯程式
2 對工作表SHEET1 按左鍵二下
3 於右側視窗輸入
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
Dim T0, A0, A1, A2, A3, A4, A5, A6, A7, A8, CK, SUM1 As Integer
x = Left(Target.Address, 2)
If x = "$A" Then
If (Len(Target.Value) <> 10) Then
Target.Value = "重新輸入"

Else



T0 = Asc(UCase(Left(Target.Value, 1)))
A1 = (((Val(Right(Target.Value, 9)) \ 100000000) Mod 10) * 8) Mod 10
A2 = (((Val(Right(Target.Value, 8)) \ 10000000) Mod 10) * 7) Mod 10
A3 = (((Val(Right(Target.Value, 7)) \ 1000000) Mod 10) * 6) Mod 10
A4 = (((Val(Right(Target.Value, 6)) \ 100000) Mod 10) * 5) Mod 10
A5 = (((Val(Right(Target.Value, 5)) \ 10000) Mod 10) * 4) Mod 10
A6 = (((Val(Right(Target.Value, 4)) \ 1000) Mod 10) * 3) Mod 10
A7 = (((Val(Right(Target.Value, 3)) \ 100) Mod 10) * 2) Mod 10
A8 = (((Val(Right(Target.Value, 2)) \ 10) Mod 10) * 1) Mod 10
CK = Val(Right(Target.Value, 1))
Select Case T0
Case 65, 77, 87
A0 = 0
Case 75, 76, 89
A0 = 1
Case 74, 86, 88
A0 = 2
Case 72, 85
A0 = 3
Case 84, 71
A0 = 4
Case 70, 83
A0 = 5
Case 69, 82
A0 = 6
Case 68, 81, 79
A0 = 7
Case 67, 80, 73
A0 = 8
Case 66, 78, 90
A0 = 9
Case Else
' ActiveCell.Formula = "重新輸入"
Target.Value = "重新輸入"
End Select
SUM1 = 9 - ((A0 + A1 + A2 + A3 + A4 + A5 + A6 + A7 + A8) Mod 10)
If CK <> SUM1 Then

Target.Value = "重新輸入"
End If

End If


End If
End Sub

4 於A欄輸入身份字號 , 就知到答案了