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 "您選擇的區(qū)域過(guò)大！"
? ? ? ? Exit Sub
? ? End If
? ? ar = Selection
? ? Set rngs = Application.InputBox("請(qǐng)選擇存放結(jié)果的區(qū)域", "提示", , , , , , 8)
? ?
? ? '一個(gè)單元格
? ? If Selection.Cells.Count = 1 Then
? ? ? ? tmp = IDBirthday(ar)
? ? ? ? ar = tmp
? ? ? ?
? ? ? ? rngs.Cells(1, 1) = ar
? ? ? ? Exit Sub
? ? End If
? ?
? ? '多個(gè)單元格
? ? 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 = "無(wú)效"
? ? 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 "您選擇的區(qū)域過(guò)大！"
? ? ? ? Exit Sub
? ? End If
? ? ar = Selection
? ? Set rngs = Application.InputBox("請(qǐng)選擇存放結(jié)果的區(qū)域", "提示", , , , , , 8)
? ?
? ? '一個(gè)單元格
? ? If Selection.Cells.Count = 1 Then
? ? ? ? tmp = IDSex(ar)
? ? ? ? ar = tmp
? ? ? ?
? ? ? ? rngs.Cells(1, 1) = ar
? ? ? ? Exit Sub
? ? End If
? ?
? ? '多個(gè)單元格
? ? 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 = "無(wú)效身份證號(hào)"
? ? ? ? ? ? Exit Function
? ? End Select
? ?
? ?
? ? If Int(s / 2) = s / 2 Then? ? ? ? ? ? ? '是否為偶數(shù)
? ? ? ? IDSex = "女"? ? ? ? ? ? ? ? ? ? ? ? ? '如果是，則性別=女
? ? Else? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? '否則
? ? ? ? IDSex = "男"? ? ? ? ? ? ? ? ? ? ? ? ? '性別=女
? ? End If
End Function? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? '結(jié)束循環(huán)
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 "您選擇的區(qū)域過(guò)大！"
? ? ? ? Exit Sub
? ? End If
? ? ar = Selection
? ? Set rngs = Application.InputBox("請(qǐng)選擇存放結(jié)果的區(qū)域", "提示", , , , , , 8)
? ? '一個(gè)單元格
? ? If Selection.Cells.Count = 1 Then
? ? ? ? tmp = IDAge(ar)
? ? ? ? ar = tmp
? ? ? ? rngs.Cells(1, 1) = ar
? ? ? ? Exit Sub
? ? End If
? ? '多個(gè)單元格
? ? 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 = "無(wú)效"
? ? ? ? ? ? Exit Function
? ? End Select
? ? IDAge = Year(Date) - Year(rlt)
End Function
4、Sub 身份證驗(yàn)證真假()
? ? 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 "您選擇的區(qū)域過(guò)大！"
? ? ? ? Exit Sub
? ? End If
? ? ar = Selection
? ? Set rngs = Application.InputBox("請(qǐng)選擇存放結(jié)果的區(qū)域", "提示", , , , , , 8)
? ?
? ? '一個(gè)單元格
? ? If Selection.Cells.Count = 1 Then
? ? ? ? tmp = CheckID(ar)
? ? ? ? ar = tmp
? ? ? ?
? ? ? ? rngs.Cells(1, 1) = ar
? ? ? ? Exit Sub
? ? End If
? ?
? ? '多個(gè)單元格
? ? 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 = "舊身份證號(hào)"
? ? ? ? ? ? ? ? Exit Function
? ? ? ? ? ? Case 18
? ? ? ? ? ?
? ? ? ? ? ? Case 0
? ? ? ? ? ? ? ? CheckID = ""
? ? ? ? ? ? ? ? Exit Function
? ? ? ? ? ? Case Else
? ? ? ? ? ? ? ? CheckID = "無(wú)效身份證號(hào)"
? ? ? ? ? ? ? ? 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
歡迎進(jìn)去財(cái)稅賦能群，如想加我我們請(qǐng)先加微信572042107
