用VBA实现身份证号码提取出生日期及性别问题?

fsc163198

参考下这个帖子 身份证分析
http://club.excelhome.net/thread-794458-5-1.html

sp008

蓝桥玄霜 发表于 2011-8-3 16:25
请见附件。

蓝桥老师这个表里再加一列自动算出周岁该怎么写代码呢

蓝桥玄霜

sp008 发表于 2012-1-18 15:35
蓝桥老师这个表里再加一列自动算出周岁该怎么写代码呢

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
   
4. Dim rq, xb$, y, m, r, sui
   
5. If Len(Target.Value) = 15 Then
   
6.     y = "19" & Mid(Target.Value, 7, 2): m = Mid(Target.Value, 8, 2): r = Mid(Target.Value, 10, 2)
   
7.     rq = DateSerial(y, m, r)
   
8.     xb = IIf(Val(Right(Target.Value, 1)) Mod 2 = 1, "男", "女")
   
9.     sui = DateDiff("yyyy", rq, Now())
   
10. ElseIf Len(Target.Value) = 18 Then
    
11.     y = Mid(Target.Value, 7, 4): m = Mid(Target.Value, 11, 2): r = Mid(Target.Value, 13, 2)
    
12.     rq = DateSerial(y, m, r)
    
13.     xb = IIf(Val(Mid(Target.Value, 15, 3)) Mod 2 = 1, "男", "女")
    
14.     sui = DateDiff("yyyy", rq, Now())
    
15. Else
    
16.     rq = "": xb = "": Target = "": sui = ""
    
17. End If
    
18. Target.Offset(0, 2) = rq
    
19. Target.Offset(0, 3) = xb
    
20. Target.Offset(0, 5) = sui
    
21. End Sub
    

复制代码

zhangzhenxia

蓝桥玄霜 发表于 2011-8-3 16:25
请见附件。

输入15位好像得到的出生日期不对，比如输入：310107490603161 出生日期显示：1956-07-30

苍蝇

zhangzhenxia 发表于 2012-1-18 16:47
输入15位好像得到的出生日期不对，比如输入：310107490603161 出生日期显示：1956-07-30

根据 蓝桥玄霜 的代码改了一下。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
   
4. Dim rq, xb$, y, m, r, sui
   
5. If Len(Target.Value) = 15 Then
   
6.     y = "19" & Mid(Target.Value, 7, 2): m = Mid(Target.Value, 9, 2): r = Mid(Target.Value, 11, 2)
   
7.     rq = DateSerial(y, m, r)
   
8.     xb = IIf(Val(Right(Target.Value, 1)) Mod 2 = 1, "男", "女")
   
9.     sui = DateDiff("yyyy", rq, Now())
   
10. ElseIf Len(Target.Value) = 18 Then
    
11.     y = Mid(Target.Value, 7, 4): m = Mid(Target.Value, 11, 2): r = Mid(Target.Value, 13, 2)
    
12.     rq = DateSerial(y, m, r)
    
13.     xb = IIf(Val(Mid(Target.Value, 15, 3)) Mod 2 = 1, "男", "女")
    
14.     sui = DateDiff("yyyy", rq, Now())
    
15. Else
    
16.     rq = "": xb = "": Target = "": sui = ""
    
17. End If
    
18. Target.Offset(0, 2) = rq
    
19. Target.Offset(0, 3) = xb
    
20. Target.Offset(0, 5) = sui
    
21. End Sub
    

复制代码

sp008

蓝桥玄霜 发表于 2012-1-18 16:16

老师这个方法好象算出的周岁不对，比如我是1971年5月14日出生，应该到2012年5月14日才41周岁，用这个方法现在就41了

沟壑中的鱼庚

蓝桥玄霜 发表于 2011-8-3 16:25
请见附件。

Private Sub Worksheet_Change(ByVal Target As Range)
老师  如果同一个sheet中已经有了Private Sub Worksheet_Change(ByVal Target As Range)这个定义的代码   又有一段代码也有Private Sub Worksheet_Change(ByVal Target As Range)，会出现二次定义，请问老师改怎么使他们不一样呢？

鲜橙加冰

蓝桥玄霜 发表于 2012-1-18 16:16

蓝老师你的代码对批量粘贴进来的身份证是无效的，能改一下吗

蓝桥玄霜

对批量粘贴的数据只能用按钮解决。

zwh3311085

这样好改吗？ 身份证0803.zip (8.07 KB, 下载次数: 132)

2014-11-6 11:32 上传

点击文件名下载附件

谢谢！