[已解决]求提取身份证号码中的出生年月日VBA

laicaiqian12

求提取身份证号码中的出生年月日代码，要求：
1、弹出窗口要求输入身份证号所在列
2、弹出窗口要求数据出生日期将要生成到的列
3、身份证号码有15位和18位之分，我的测试附件只有18位的，但真正使用可能会有15位。

最佳答案

月排行榜 / 总排行榜

xdragon

2013-10-12 18:16

1. Sub test()
   
2. Dim rngs As Range, arr()
   
3. Top:
   
4. Set rngs = Application.InputBox("请输入身份证号码所在的区域", "提示", , , , , , 8)
   
5. If rngs.Columns.Count > 1 Then
   
6.   MsgBox "只支持一列身份证号码的计算,请重新输入"
   
7.   GoTo Top
   
8. End If
   
9. arr = Intersect(rngs, ActiveSheet.UsedRange)
   
10. For i = 1 To UBound(arr)
    
11.   Select Case Len(arr(i, 1))
    
12.     Case 15
    
13.       arr(i, 1) = Format("19" & Mid(arr(i, 1), 7, 6), "0000-00-00")
    
14.     Case 18
    
15.       arr(i, 1) = Format(Mid(arr(i, 1), 7, 8), "0000-00-00")
    
16.     Case 0
    
17.       arr(i, 1) = ""
    
18.     Case Else
    
19.       arr(i, 1) = "身份证号码有误"
    
20.   End Select
    
21. Next
    
22. Set rngs = Application.InputBox("请选择生日的导出区域", "提示", , , , , , 8)
    
23. rngs.Resize(UBound(arr)) = arr
    
24. End Sub
    

复制代码

跳转到最佳答案楼层

那么的帅

提供数据附件，并提供测试数据

laicaiqian12

那么的帅 发表于 2013-10-12 17:36
提供数据附件，并提供测试数据

已经添加测试附件，感谢您的关注。

那么的帅

laicaiqian12 发表于 2013-10-12 17:39
已经添加测试附件，感谢您的关注。

要生成到的列
结果做出几个实例

xdragon

1. Sub test()
   
2. Dim rngs As Range, arr()
   
3. Top:
   
4. Set rngs = Application.InputBox("请输入身份证号码所在的区域", "提示", , , , , , 8)
   
5. If rngs.Columns.Count > 1 Then
   
6.   MsgBox "只支持一列身份证号码的计算,请重新输入"
   
7.   GoTo Top
   
8. End If
   
9. arr = Intersect(rngs, ActiveSheet.UsedRange)
   
10. For i = 1 To UBound(arr)
    
11.   Select Case Len(arr(i, 1))
    
12.     Case 15
    
13.       arr(i, 1) = Format("19" & Mid(arr(i, 1), 7, 6), "0000-00-00")
    
14.     Case 18
    
15.       arr(i, 1) = Format(Mid(arr(i, 1), 7, 8), "0000-00-00")
    
16.     Case 0
    
17.       arr(i, 1) = ""
    
18.     Case Else
    
19.       arr(i, 1) = "身份证号码有误"
    
20.   End Select
    
21. Next
    
22. Set rngs = Application.InputBox("请选择生日的导出区域", "提示", , , , , , 8)
    
23. rngs.Resize(UBound(arr)) = arr
    
24. End Sub
    

复制代码

laicaiqian12

xdragon 发表于 2013-10-12 18:16

大湿，为何我生成的身日列标题名称是“省份证号码有误”呢？

姓名	身份证号码	手机	身份证号码有误
王晓恒	410422199012107014	13525356802	1990-12-10
王璐瑶	410422199301121023	13525359666	1993-1-12
兰明言	410422198208022253	13525359666	1982-8-2
王家明	410422199305104327	13525360519	1993-5-10
石建业	410422199003143339	13525372157	1990-3-14
李艳艳	41042219900408334X	13525375750	1990-4-8
刘振亚	410422199202054339	13525376175	1992-2-5
袁雪丽	410185198811044026	13525383394	1988-11-4
赵根水	410422199211108132	13525384551	1992-11-10
徐朋飞	410422199112277010	13525384692	1991-12-27
贾亚锋	410422199203023390	13525384692	1992-3-2
张小飞	410422199012217037	13525384932	1990-12-21

xdragon

arr(i, 1) = "身份证号码有误"

是这句语句造成的  因为这个不是身份证号码么，如果不需要你可以删了

1. 18.    Case Else
   
2. 
   
3. 19.      arr(i, 1) = "身份证号码有误"
   
4. 
   

复制代码

这两行代码