最新WPS办公软件学习教程_免费企业办公软件下载_金山WPS Office官网论坛

 找回密码
 
查看: 12903|回复: 33

[VBA/VBS教程] 身份证转出生日期一劳永逸的解决方案(改进版1)

  [复制链接]

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

Rank: 14Rank: 14Rank: 14Rank: 14

该用户从未签到

金币
984
威望
8204
帖子
842
精华
3

WPS粉丝团 技术分享团 解答支持团 测试体验团 重阳节勋章 技巧教程分享达人 最佳教程奖 优秀会员奖

发表于 2012-10-16 14:39 |显示全部楼层
分享到: 新浪微博 腾讯微博
身份证转出生日期一劳永逸的解决方案发表后,得到技术分享团水月团长的大力支持,不但纠正了其中的一个错误,更提出了更加严格检查身份证号码是否合法的建议。而且他还推出了相应的公式版方法。/ w3 v: M7 b0 H& S! P5 C
这里首先感谢水月团长,@松风水月
3 P. r! G1 f* S- l: W6 Z
+ ~( ?" X" X; f  {原贴:身份证转出生日期一劳永逸的解决方案
  u- [1 F) R/ A4 _        
http://bbs.wps.cn/thread-22346981-1-1.html
) P4 ^# y, |8 @) Z9 FET中有此功能,但是ET会忽略月份和日子里面的首位的0
9 S0 T! `! H$ s; F" Q即ET中会出现这种情况:0 g8 D& ^( G. a" B4 k
2012-1-1
1 o4 v7 @. p7 F  t4 H2 ]' C/ B而很多时候,我们对格式的要求很高,比如一定要如下的格式:
% _) _6 W* K( F2012-01-013 K, A# u- ^9 `% F$ r) Y7 [( q
而且,只能用"-"连接也可能在有时不适用,比如我们要这样的格式* `  F4 K" V) n- Y4 u8 r/ H- J
2012/01/01
( ?1 x4 |0 {( S  t# b3 A或者
2 L4 m, e5 @* F2012年01月01月
2 b: x! ^1 ?$ x: |) [7 F
此时,在ET在可能的解决办法是设置单元格格式,自定义格式。
8 u4 z$ N8 |) p# P9 }" [但是,这样太麻烦,而且不一定能达到我们想要的格式。" u' Y4 S5 u: b* o4 I0 D! a
为此,我们使用VBA开发自定义函数。4 _; `3 r7 I- ?& J- B0 ~

/ }$ b+ T' [! s$ W( G' u9 {
身份证转出生日期一劳永逸的解决方案(改进版1)
5 R1 x% |' B! M5 W5 a改进:; |. U7 k6 n: K( I* Y; Q
1.对于15位身份证号修复了第7位为0时年份以20开头的问题,正确的应该是19开头7 z2 I& q* w9 A7 S
2.对于身份证号的检查更加严格,必须是15位纯数字,或者17位纯数字+"0123456789xX"其中之一
! |5 P4 ~) c& ~( H& q: z好了,先看图:0 S& d9 O. D5 t6 u

6 g! ^9 U. w' Q3 }% S再接着是代码:
  1. '判断char的首字符是不是在str中9 f% Y+ n0 n% C+ k; A' V" I
  2. Public Function CharInStr(ByVal char As String, ByVal str As String) As Integer
    ! i7 P! X2 u9 E8 R4 o
  3. Application.ScreenUpdating = False '关闭屏幕更新,加快速度
    8 p) M) f" {# t6 X$ ^' @
  4. On Error Resume Next
    * C5 z4 i, f9 b% `. ~9 p7 _
  5. If Len(char) = 0 Or Len(str) = 0 Then8 M" ?+ V2 [( H% W" J7 @$ N
  6. CharInStr = 0: Exit Function '长度为零,退出* d+ X1 O; T. l3 D( k$ d* A! o" a
  7. Else
    7 d% z% d7 [% H5 @" E4 t) P
  8. char = Mid(char, 1, 1)  c6 o/ `; k5 ?% x
  9. CharInStr = InStr(str, char)
    # F9 t# W1 V- O9 F: w+ }' T
  10. End If: w: S- U9 ^. e6 Y" Q- x# a9 J9 x
  11. Application.ScreenUpdating = True '恢复屏幕更新
    ! s2 e8 r4 O) u4 `, G4 w# |# l; @
  12. End Function; C2 N/ ?' J8 o5 T' A, Z$ Z! D
  13. . y$ P- {6 {" |8 K, ?. q7 A
  14. 'IsOkSFZID 判断是否是合法的身份证号4 a( b' t  G7 r: v
  15. Public Function IsOkSFZID(ByVal str As String) As Boolean; L- b' ?* b9 i* y) y
  16. Application.ScreenUpdating = False '关闭屏幕更新,加快速度
    % |% i& Y& P: ]0 ?4 l: M0 Y. k
  17. On Error Resume Next
    ! O) n& E1 u7 ]+ Z4 `; \
  18. Dim Length As Integer
    ' R; t: I/ v3 j/ l
  19. Length = Len(str)$ [( R& O1 x2 o8 w* X  L7 H
  20. If Length <> 15 And Length <> 18 Then$ ~' c, u' ^4 W: F% b. i7 H) k: o
  21. IsOkSFZID = False: Exit Function '长度不满足要求,返回假,退出
    ' T6 P& ?+ [7 D
  22. ElseIf Length = 15 Then '15位必须纯数字
    ( h% A# u7 P. z# Y
  23. For i = 1 To 157 m  u! A+ g/ J- I4 e" }+ K3 M
  24. If CharInStr(Mid(str, i, 1), "0123456789") = 0 Then& M8 ]+ G/ f" d
  25. IsOkSFZID = False: Exit Function '有非数字,返回假,退出
    ) @5 J1 c+ @  h
  26. End If  q' X, k# `: V, U2 ]7 R
  27. Next i
    8 {- e1 w3 O4 e
  28. ElseIf Length = 18 Then '18位必须纯数字或者前17位纯数字,最后一位是大写或小写的X3 f3 b% Y- w% d4 p3 }
  29. For i = 1 To 17
    ( Z4 @* r& y* S
  30. If CharInStr(Mid(str, i, 1), "0123456789") = 0 Then6 G* d1 u  v8 A: a4 I4 i" w0 w: X) V
  31. IsOkSFZID = False: Exit Function '有非数字,返回假,退出
    # ^% M- k# P/ m: K9 ]& N! B
  32. End If
    ! B5 e( a$ y7 o9 g, Z
  33. Next i
    ; C/ p( G$ d- Z, t& n
  34. If CharInStr(Mid(str, 18, 1), "0123456789xX") = 0 Then3 O8 n; f1 m' I4 j
  35. IsOkSFZID = False: Exit Function '第18位不是数字或字母X(不分大小写),返回假,退出, H$ V% u9 w2 q. H, n0 J
  36. End If& |/ G/ {2 g8 g
  37. End If
    4 Q* U( m& {# c9 ?
  38. IsOkSFZID = True '能运行到这一步还没有退出函数的,说明符合要求,返回真8 l; r" F9 p3 u/ @4 z
  39. Application.ScreenUpdating = True '恢复屏幕更新* G: W( u, d6 H! v: v# T7 T5 \
  40. End Function0 o+ x5 ^1 J7 K
  41. 3 O2 g: y. y9 c2 X7 h
  42. '身份证转出生日期1; R, C0 K; j3 J
  43. '产生的格式形如 2012-01-01 ,其中,"-" 可由第二参数替换为任意字符,比如2012/01/01" t' n- F: z* S) F' W( `
  44. Public Function SFZtoDate(ByVal cell As Range, Optional ByVal strAnd As String = "-")
    : r! X! C7 T) S. I/ L+ h2 U( K
  45. Application.ScreenUpdating = False '关闭屏幕更新,加快速度
    8 [; S) J) z8 n( y9 O% A
  46. On Error Resume Next '防错处理
    & U/ w  [3 h5 Y+ o' p! D5 P4 R
  47. If IsOkSFZID(cell.Text) = False Then+ r4 o* r+ x/ a/ X- N* g. \
  48. SFZtoDate = "号码错误": Exit Function '如果身份证号不符合要求,则返回空白6 m4 ~" v  A7 P! \' L1 i
  49. End If
    5 L2 @/ O# I" H( k" t0 y  M6 Q
  50. '如果身份证号为15位,那么使用“19”连接第7位开始6位数,且使用 strAnd作为年、月、日的分隔符,结果为出生日期
    $ ]/ M+ n, d- b+ V' ^2 |: B
  51. If Len(cell.Text) = 15 Then  A) L* E; B" F7 N: K4 B
  52. SFZtoDate = "19" & Mid(cell.Text, 7, 2) & strAnd & Mid(cell.Text, 9, 2) & strAnd & Mid(cell.Text, 11, 2)4 o% V+ h$ o& p4 E* O
  53. End If
    9 a& L( L, \# b9 a4 @5 Y8 b
  54. '如果身份证号为18位,那么从第7位开始取8位数,且使用strAnd作为年、月、日的分隔符,结果为出生日期(第7到14位表示出生年月日)
      o7 T: p# P! M% B8 ?
  55. If Len(cell.Text) = 18 Then
    / Z; `. D; N* z  p- k. [
  56. SFZtoDate = Mid(cell.Text, 7, 4) & strAnd & Mid(cell.Text, 11, 2) & strAnd & Mid(cell.Text, 13, 2)
    , \* R( G% V% N
  57. End If
    5 C7 X  j) I. O+ O
  58. Application.ScreenUpdating = True '恢复屏幕更新/ a. L8 |. x6 _+ Q
  59. End Function& |- T( ^) V, T2 Q! [6 M9 s
  60. 1 ]6 b! O1 n* L, w4 I7 a- ?2 T
  61. '身份证转出生日期2
    # ~. h% U3 b% d2 P  }
  62. '产生的格式形如 2012年01月01日 ,其中,"年","月","日" 可由第2-4参数替换为任意字符,比如2012Year01Month01Day
      Q3 t; ~; T9 l7 x8 v% O
  63. Public Function SFZtoDateEx(ByVal cell As Range, Optional ByVal strY As String = "年", Optional ByVal strM As String = "月", Optional ByVal strD As String = "日")1 {+ r& j' i. k$ f. U  j" C7 |
  64. Application.ScreenUpdating = False '关闭屏幕更新,加快速度
    ) Y6 I( _' h" N; x' ^& o
  65. On Error Resume Next- G5 y: ]3 A$ T" H" X3 T' k
  66. If IsOkSFZID(cell.Text) = False Then
      {+ [+ ~' Y) ^4 ~# |& L
  67. SFZtoDateEx = "号码错误": Exit Function '如果身份证号不符合要求,则返回空白
    7 J0 X, R* |% T" r, q
  68. End If
    % P4 ]: k: P/ x/ \4 k$ ~& |
  69. If Len(cell.Text) = 15 Then1 c+ D/ z, z- X# H2 J' v
  70. SFZtoDateEx = "19" & Mid(cell.Text, 7, 2) & strY & Mid(cell.Text, 9, 2) & strM & Mid(cell.Text, 11, 2) & strD) `, x; |, i1 y* @4 Q0 `( K
  71. End If$ g) e5 D6 a. h. n2 k. D
  72. If Len(cell.Text) = 18 Then, N4 l" v- Z  O) T+ l/ p
  73. SFZtoDateEx = Mid(cell.Text, 7, 4) & strY & Mid(cell.Text, 11, 2) & strM & Mid(cell.Text, 13, 2) & strD/ B3 B( K; m  p5 F7 K! z
  74. End If( Q$ T1 o# L0 T1 }/ i
  75. Application.ScreenUpdating = True '恢复屏幕更新' k3 M9 W; W! f: G  ?
  76. End Function
复制代码
最后,当然还是送上ET文档:! r$ b8 [4 _& Z5 u! T8 j# l. W
/ O1 @# a+ t* j5 |0 Z  z+ s3 `. V
$ h  w' `9 e2 Y' |+ h& j: M

本帖子中包含更多资源

您需要 登录 才可以下载或查看,

已有 3 人评分威望 收起 理由
shandaqk + 1 很给力!
1149737746 + 10 很给力!
松风水月 + 15 赞一个!

总评分: 威望 + 26   查看全部评分

热爱分享和学习。希望WPS论坛越办越好,WPS软件越做越好。也希望能在这里交到更多志同道合的朋友。我的邮箱:ypr@yprnet.com
我在WPS论坛上的教程帖子合集: http://blog.yprnet.com/wps

19

主题

108

听众

5338

积分

技术分享团长

Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20

签到天数: 5 天

[LV.2]偶尔看看I

金币
5316
威望
11825
帖子
2334
精华
1

WPS粉丝团 荣誉版主奖 活跃会员奖 技术分享团 解答支持团 重阳节勋章

发表于 2012-10-16 18:21 |显示全部楼层
楼主真是辛苦了!向楼主致敬!{:soso_e179:}

本帖子中包含更多资源

您需要 登录 才可以下载或查看,

回复

使用道具 举报

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

Rank: 14Rank: 14Rank: 14Rank: 14

该用户从未签到

金币
984
威望
8204
帖子
842
精华
3

WPS粉丝团 技术分享团 解答支持团 测试体验团 重阳节勋章 技巧教程分享达人 最佳教程奖 优秀会员奖

发表于 2012-10-16 18:29 |显示全部楼层
松风水月 发表于 2012-10-16 18:21 . q6 _. {6 }% h/ n0 c; R. S
楼主真是辛苦了!向楼主致敬!

* K  O- @- A9 L* u' C: l8 G; h这都是你的意见和建议让我进步的啊,实在是非常感谢!
回复

使用道具 举报

0

主题

0

听众

300

积分

LV.4

Rank: 4

该用户从未签到

金币
32
威望
499
帖子
282
精华
0
发表于 2012-10-16 19:53 |显示全部楼层
好样的,支持
回复

使用道具 举报

2

主题

4

听众

106

积分

LV.3

Rank: 3Rank: 3

该用户从未签到

金币
0
威望
218
帖子
70
精华
0

WPS粉丝团

发表于 2012-10-17 15:03 |显示全部楼层
向楼主致敬!
回复

使用道具 举报

1

主题

0

听众

9

积分

LV.1

Rank: 1

该用户从未签到

金币
0
威望
17
帖子
8
精华
0
发表于 2012-10-17 15:27 |显示全部楼层
楼主真强大  向你致敬  WPS 有你更精彩{:1_12:}{:1_12:}
回复

使用道具 举报

8

主题

0

听众

53

积分

LV.2

Rank: 2

该用户从未签到

金币
0
威望
84
帖子
51
精华
0
发表于 2012-10-18 15:05 |显示全部楼层
讲解的非常不错 学习了
回复

使用道具 举报

0

主题

0

听众

3

积分

LV.1

Rank: 1

该用户从未签到

金币
0
威望
3
帖子
1
精华
0
发表于 2012-10-23 08:19 |显示全部楼层
非常感谢
回复

使用道具 举报

0

主题

0

听众

709

积分

LV.5

Rank: 5Rank: 5

该用户从未签到

金币
163
威望
1985
帖子
190
精华
0
发表于 2013-2-26 09:04 |显示全部楼层
看不明白是什么意思啊,而且下载的那个et用不来,有教程吗楼主
回复

使用道具 举报

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

Rank: 14Rank: 14Rank: 14Rank: 14

该用户从未签到

金币
984
威望
8204
帖子
842
精华
3

WPS粉丝团 技术分享团 解答支持团 测试体验团 重阳节勋章 技巧教程分享达人 最佳教程奖 优秀会员奖

发表于 2013-2-26 10:34 |显示全部楼层
Outes 发表于 2013-2-26 09:04 ' @- D# R( p7 V' b: @% ^4 u6 X- A
看不明白是什么意思啊,而且下载的那个et用不来,有教程吗楼主
$ \  G/ ?/ G- r7 j
可能你没有安装VBA环境,所以无法使用
6 G( n( c; ~) |& B# l0 I9 B  u! M; q" Z" G+ P
VBA环境可以在这里下载http://bbs.wps.cn/thread-22347925-1-1.html
回复

使用道具 举报

*滑动验证:
您需要登录后才可以回帖 登录 | 更多账号登录:

快速回帖:

fastpost

WPS论坛更新日志|WPS Office官方论坛     

GMT+8, 2017-11-25 09:37

Powered by Discuz! X2.5

© 2001-2012 Comsenz Inc.

回顶部