1、Sub 提取身份证出生日期()
On Error Resume Next
Dim ar, i, ii
Dim tmp
If Selection.Areas.Count > 1 Then Exit Sub
If Selection.Cells.Count > Columns.Count Then
MsgBox "您选择的区域过大！"
Exit Sub
End If
ar = Selection
Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)
'一个单元格
If Selection.Cells.Count = 1 Then
tmp = IDBirthday(ar)
ar = tmp
rngs.Cells(1, 1) = ar
Exit Sub
End If
'多个单元格
Randomize Timer
For i = 1 To UBound(ar)
For ii = 1 To UBound(ar, 2)
tmp = IDBirthday(ar(i, ii))
ar(i, ii) = tmp
Next
Next
rngs.Resize(UBound(ar), UBound(ar, 2)) = ar
End Sub
Function IDBirthday(sid) As String
Dim rlt
Select Case Len(sid)
Case 15
rlt = Format("19" & mid(sid, 7, 6), "0000-00-00")
Case 18
rlt = Format(mid(sid, 7, 8), "0000-00-00")
Case 0
rlt = ""
Case Else
rlt = "无效"
End Select
IDBirthday = rlt
End Function
2、Sub 提取身份证性别()
On Error Resume Next
Dim ar, i, ii
Dim tmp
If Selection.Areas.Count > 1 Then Exit Sub
If Selection.Cells.Count > Columns.Count Then
MsgBox "您选择的区域过大！"
Exit Sub
End If
ar = Selection
Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)
'一个单元格
If Selection.Cells.Count = 1 Then
tmp = IDSex(ar)
ar = tmp
rngs.Cells(1, 1) = ar
Exit Sub
End If
'多个单元格
Randomize Timer
For i = 1 To UBound(ar)
For ii = 1 To UBound(ar, 2)
tmp = IDSex(ar(i, ii))
ar(i, ii) = tmp
Next
Next
rngs.Resize(UBound(ar), UBound(ar, 2)) = ar
End Sub
Function IDSex(sid)
Dim s As String
Select Case Len(sid)
Case 15
s = Right(sid, 1)
Case 18
s = mid(sid, 17, 1)
Case 0
IDSex = ""
Exit Function
Case Else
IDSex = "无效身份证号"
Exit Function
End Select
If Int(s / 2) = s / 2 Then '是否为偶数
IDSex = "女" '如果是，则性别=女
Else '否则
IDSex = "男" '性别=女
End If
End Function '结束循环
3、Sub 提取身份证的年龄()
On Error Resume Next
Dim ar, i, ii
Dim tmp
If Selection.Areas.Count > 1 Then Exit Sub
If Selection.Cells.Count > Columns.Count Then
MsgBox "您选择的区域过大！"
Exit Sub
End If
ar = Selection
Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)
'一个单元格
If Selection.Cells.Count = 1 Then
tmp = IDAge(ar)
ar = tmp
rngs.Cells(1, 1) = ar
Exit Sub
End If
'多个单元格
Randomize Timer
For i = 1 To UBound(ar)
For ii = 1 To UBound(ar, 2)
tmp = IDAge(ar(i, ii))
ar(i, ii) = tmp
Next
Next
rngs.Resize(UBound(ar), UBound(ar, 2)) = ar
End Sub
Function IDAge(sid) As String
Dim rlt As Date
Select Case Len(sid)
Case 15
rlt = Format("19" & mid(sid, 7, 6), "0000-00-00")
Case 18
rlt = Format(mid(sid, 7, 8), "0000-00-00")
Case 0
IDAge = ""
Exit Function
Case Else
IDAge = "无效"
Exit Function
End Select
IDAge = Year(Date) - Year(rlt)
End Function
4、Sub 身份证验证真假()
On Error Resume Next
Dim ar, i, ii
Dim tmp
If Selection.Areas.Count > 1 Then Exit Sub
If Selection.Cells.Count > Columns.Count Then
MsgBox "您选择的区域过大！"
Exit Sub
End If
ar = Selection
Set rngs = Application.InputBox("请选择存放结果的区域", "提示", , , , , , 8)
'一个单元格
If Selection.Cells.Count = 1 Then
tmp = CheckID(ar)
ar = tmp
rngs.Cells(1, 1) = ar
Exit Sub
End If
'多个单元格
Randomize Timer
For i = 1 To UBound(ar)
For ii = 1 To UBound(ar, 2)
tmp = CheckID(ar(i, ii))
ar(i, ii) = tmp
Next
Next
rngs.Resize(UBound(ar), UBound(ar, 2)) = ar
End Sub
Public Function CheckID(ByVal ID18 As String) As String
Dim rlt As String
Dim Ai(17) As Integer
Select Case Len(ID18)
Case 15
CheckID = "旧身份证号"
Exit Function
Case 18
Case 0
CheckID = ""
Exit Function
Case Else
CheckID = "无效身份证号"
Exit Function
End Select
CC = "10X98765432"
Wi = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
s = 0
For i = 0 To 16
Ai(i) = CInt(mid(ID18, i + 1, 1))
s = s + Ai(i) * Wi(i)
Next i
rlt = mid(CC, s Mod 11 + 1, 1)
If Right(ID18, 1) = rlt Then
CheckID = "真"
Else
CheckID = "假"
End If
End Function
欢迎进去财税赋能群，如想加我我们请先加微信572042107
