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

尒愺

用身份证号提取出生日期及性别,本人用函数能够实现.但是现在想用VBA来实现.也就是说,不想把公式写在单元格中,写在单元格中很容易被删掉.所以想把公式写在VBA窗口中.当输入身份证号时,对应的列能自动生成出生日期和性别.
求各位老师帮忙!谢谢!

BOOK1.rar (2.25 KB, 下载次数: 242)

2011-8-3 16:01 上传

点击文件名下载附件

wucaoding2

保护了就不怕被删除了

蓝桥玄霜

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
   
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. ElseIf Len(Target.Value) = 18 Then
   
10.     y = Mid(Target.Value, 7, 4): m = Mid(Target.Value, 11, 2): r = Mid(Target.Value, 13, 2)
    
11.     rq = DateSerial(y, m, r)
    
12.     xb = IIf(Val(Mid(Target.Value, 15, 3)) Mod 2 = 1, "男", "女")
    
13. Else
    
14.     rq = "": xb = "": Target = ""
    
15. End If
    
16. Target.Offset(0, 2) = rq
    
17. Target.Offset(0, 3) = xb
    
18. End Sub
    

复制代码

蓝桥玄霜

请见附件。

flysum2008

Sub aa()
With Sheet1
arr = Range("a2", [a65536].End(3))
End With
For i = 1 To UBound(arr)
hm = arr(i, 1)
nl = Mid(hm, 17, 1)
Cells(i + 1, 3) = Mid(hm, 7, 4) & "-" & Mid(hm, 11, 2) & "-" & Mid(hm, 13, 2)
If nl Mod 2 = 0 Then
Cells(i + 1, 4) = "女"
Else
Cells(i + 1, 4) = "男"
End If
Next
End Sub

flysum2008

请见附件。学习蓝桥玄霜 老师的代码。

heartace75

1. 
   
2. 
   
3. Option Explicit
   
4. 
   
5. Private Sub Worksheet_Change(ByVal Target As Range)
   
6.    
   
7.     '检测数据是否在A列2行之下
   
8.     If (Target.Column = 1 And Target.Row > 1) Then
   
9.         
   
10.         '检测数据是否为单个字符串
    
11.         If (TypeName(Target.Value) <> "String") Then Exit Sub
    
12.    
    
13.         Dim id As String
    
14.         id = Target.Value
    
15.         
    
16.         '检测数据是否为18位
    
17.         If (Strings.Len(id) = 18) Then
    
18.         
    
19.             Dim sex As Integer
    
20.             Dim sexStr As String
    
21.             
    
22.             '取得第17位数字
    
23.             On Error GoTo ErrorHandler
    
24.             sex = CInt(Strings.Mid(id, 17, 1))
    
25.             
    
26.             If (sex Mod 2 = 0) Then
    
27.                 sexStr = "女"
    
28.             Else
    
29.                 sexStr = "男"
    
30.             End If
    
31.             
    
32.             '设置当前身份证号后三列单元格的值为对应性别
    
33.             ActiveSheet.Cells(Target.Row, Target.Column + 3).Value = sexStr
    
34.             
    
35.             '取得8位出生日期值
    
36.             Dim birthStr As String
    
37.             birthStr = Strings.Mid(id, 7, 8)
    
38.                         
    
39.             birthStr = Strings.Mid(birthStr, 1, 4) & _
    
40.                 "-" & Strings.Mid(birthStr, 5, 2) & "-" & Strings.Mid(birthStr, 7, 2)
    
41.             
    
42.             '设置当前身份证号后两列单元格的值为对应生日
    
43.             ActiveSheet.Cells(Target.Row, Target.Column + 2).Value = birthStr
    
44.         End If
    
45.     End If
    
46.    
    
47.     Exit Sub
    
48.    
    
49. ErrorHandler:
    
50.     MsgBox "身份证号输入错误"
    
51.    
    
52. End Sub
    

复制代码

源码如上

[ 本帖最后由 heartace75 于 2011-8-3 18:08 编辑 ]

heartace75

刚开始玩excel vba，这是写的第一个程序，很多函数和运算符都还不知道，而且习惯加注释和用中间变量，跟蓝桥的一比顿显冗长，希望能多向各位大神学习 :)

尒愺

谢谢楼上的各位大侠!.

sp008

先记住贴子的位置，以后好找