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

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

[VBA/VBS教程] 提取身份证号码中的各种信息ET版

  [复制链接]

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

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

该用户从未签到

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

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

发表于 2012-10-21 00:38 |显示全部楼层
分享到: 新浪微博 腾讯微博
本帖最后由 天远 于 2012-10-21 13:28 编辑
! y7 A$ p' w8 A" r. b6 Y6 s6 V8 g1 \0 M
似乎天远比较喜欢发自定义函数,而且和身份证有关的比较多,各位见谅一下哈。. N% u( f. E+ I1 |0 i4 z; a6 z
今天天远带来的是一个相对比较强大的函数GetIDcardInfo,取得身份证号码中的各种信息:
/ ]* _( X1 o# a9 R! F这个函数的第一个参数为一个字符串,代表身份证号,第二个参数为整数,代表要获取的类型,具体为:
7 h+ q  M# p8 X* P: P- w1 户口所在地(采用旧版数据库)
0 u$ z8 I. z4 B# g4 x6 h2 户口所在地(采用新版数据库)1 a# G7 H; |7 N2 v) |
3 生日
( C4 z) c& p  z4 性别  I8 C+ }* S& ~. Y/ b; s8 V
5 年龄(考虑是否到达生日)4 B% c& l. K- ~/ r
6 年龄(不考虑是否到达生日)$ l" z# B7 V% a/ {' @
7 星座( u5 Q  h0 D* h' u: F% E
返回值为相关信息。
4 J4 T" Y5 m. p, W& e5 i好了,先看效果图吧:
( W% g9 U- z7 l4 z: s' ^% w& I2 u# {/ j$ G5 b, A

# G: P6 W2 [+ P- t, Y# R* ^接下来是代码:
  1. '辅助函数CharInStr,判断char的首字符是不是在str中9 ]" B8 q. x5 S3 U( _% r, |
  2. Public Function CharInStr(ByVal char As String, ByVal str As String) As Integer
    , ?. h, I6 L' e
  3. Application.ScreenUpdating = False '关闭屏幕更新,加快速度4 i8 s: j2 U& w( Z% L; K# F
  4. On Error Resume Next0 `0 Z" |/ \3 q( M, e  T$ L/ {
  5. If Len(char) = 0 Or Len(str) = 0 Then$ l; \$ n) ~' j. R2 b& z
  6.     CharInStr = 0: Exit Function '长度为零,退出
    - T5 e% u  Y% {4 H0 H$ K8 \
  7. Else" y; X' }& N$ Z% X
  8.     char = Mid(char, 1, 1)
    - e3 y) E- n/ t' P
  9.     CharInStr = InStr(str, char)
    # K% k  {9 i: q/ F! l4 |
  10. End If
    ; C) }% `4 D* {) W; h, u  m
  11. Application.ScreenUpdating = True  '恢复屏幕更新
    ( o5 k$ i1 Q! \: ?$ d. \8 B3 X
  12. End Function* O0 [: a" }1 A5 a
  13. '辅助函数IsOkSFZID,,判断是否是合法的身份证号) t( F# m/ R2 {. m$ R+ l0 K2 Q
  14. Public Function IsOkSFZID(ByVal str As String) As Boolean& {" l" o- Y2 i6 q
  15. Application.ScreenUpdating = False '关闭屏幕更新,加快速度) U9 x4 v$ e! ]" m. q
  16. On Error Resume Next3 N4 i% V; m% C- Z( L) J& |! _
  17. Dim Length As Integer( _( U  w/ |. v' f
  18. Length = Len(str)
    * r9 k: D, K6 S. `* K! V, u
  19. If Length <> 15 And Length <> 18 Then
    - e, X3 X- d+ g
  20.     IsOkSFZID = False: Exit Function  '长度不满足要求,返回假,退出
    1 }5 e7 j9 _/ U$ R
  21. ElseIf Length = 15 Then '15位必须纯数字3 h: Z: r& f( C
  22.     For i = 1 To 15
    7 x& Z+ A( M$ x
  23.         If CharInStr(Mid(str, i, 1), "0123456789") = 0 Then
    ( u2 C* u- S' u2 P
  24.             IsOkSFZID = False: Exit Function  '有非数字,返回假,退出
    . s' S( G. D9 I1 @4 R
  25.         End If, B2 i. n# ^! g% U$ F# P3 L
  26.     Next i+ `6 L; }9 g# \6 X$ h
  27. ElseIf Length = 18 Then '18位必须纯数字或者前17位纯数字,最后一位是大写或小写的X
    ; Z9 R, j) @+ e5 Z& m
  28.     For i = 1 To 17; o7 Z4 {: G/ J, E) r
  29.         If CharInStr(Mid(str, i, 1), "0123456789") = 0 Then8 |$ |8 N/ p  _8 Y, q* M/ K" n
  30.             IsOkSFZID = False: Exit Function  '有非数字,返回假,退出: a' E1 h) S- G9 j
  31.         End If/ D5 E3 n" y4 T
  32.     Next i
    * }1 U. D. e4 `# H8 r
  33.     If CharInStr(Mid(str, 18, 1), "0123456789xX") = 0 Then
    5 V9 S- M1 z/ \; m$ k5 i' N
  34.         IsOkSFZID = False: Exit Function  '第18位不是数字或字母X(不分大小写),返回假,退出4 C6 u6 I; b+ R8 v  I; M4 {1 P
  35.     End If
    ( m. ~( U) T0 A0 Z
  36. End If' t, h( g1 G* @% h* s
  37. IsOkSFZID = True '能运行到这一步还没有退出函数的,说明符合要求,返回真
    , K3 L( Z, W; X1 j+ ?) W2 e
  38. Application.ScreenUpdating = True  '恢复屏幕更新, y9 d8 M3 a$ A  H- r; H
  39. End Function  V% M+ ^, S6 ?4 {
  40. '======================
    : n: z" G  Z* g9 V0 p; Q
  41. '主函数GetIDcardInfo,取得身份证号码中的各种信息
    + X8 \( g7 X: G6 i9 w- T
  42. 'GetType参数说明
    6 b7 W& l1 D* B  w- \) J
  43. '1 户口所在地(采用旧版数据库)
    # Y" c  z) w# p
  44. '2 户口所在地(采用新版数据库)
    2 N0 [" q: C: y2 l
  45. '3 生日! o8 x% i" |# V
  46. '4 性别
    - Y. @6 i. `5 J. G: N+ |- h
  47. '5 年龄(考虑是否到达生日), p2 k) M. M$ H# G8 u1 Q
  48. '6 年龄(不考虑是否到达生日)
    3 G; a$ J7 u- V: ]! g3 |
  49. '7 星座# C/ O) }' y# @2 P- r0 Y
  50. Function GetIDcardInfo(str As Range, Optional GetType As Integer = 2) As String
    6 v& i, E' u9 R2 m
  51. Application.ScreenUpdating = False '关闭屏幕更新,加快速度
    & y5 C  H& d7 }9 @  R0 i
  52. On Error GoTo err '如果出现错误,自动跳到err段代码,只要是针对vlookup函数精确查找时没有找到结果会出错的情况8 u9 D# ]* `) Q" U# ]5 K4 I
  53. If False = IsOkSFZID(str) Then GetIDcardInfo = "号码错误": Exit Function  '号码不符合身份证号的格式,退出4 w) ]( O% m% C* K' e
  54. If GetType > 7 Or GetType < 1 Then GetIDcardInfo = "第二参数错误": Exit Function '第二参数越界,退出
    - p6 ]- |8 @  Q& ]5 z
  55. Dim temp As String  r( P7 z) V$ }' G2 e; }3 j$ Q
  56. '按第二参数处理各种情况
    0 t) D& E# L7 Z- N
  57. If GetType = 1 Then
    " o0 l# D3 S9 s0 D. m
  58.     temp = WorksheetFunction.VLookup(Mid(str, 1, 2), ThisWorkbook.Sheets(1).Range("A1:B5805"), 2, False)" \* @  A  k" l1 l( n* @
  59.     temp = temp & "-" & WorksheetFunction.VLookup(Mid(str, 1, 6), ThisWorkbook.Sheets(1).Range("A1:B5805"), 2, False)
    2 x% K  }: o+ C: B2 }4 W
  60.     GetIDcardInfo = temp
    & M' E* V& h0 p* {5 Z8 G) v$ R: A
  61.     Exit Function
    3 B% z9 h' P/ g6 Z; u
  62. End If* G$ u7 O- ~1 e( \; [4 W# D* m
  63. If GetType = 2 Then1 e& G$ j% L  n( i& g/ Z
  64.     temp = WorksheetFunction.VLookup(Val(Mid(str, 1, 6)), ThisWorkbook.Sheets(2).Range("A1:E3506"), 5, False)
    2 P: O' H1 L9 g  C
  65.     GetIDcardInfo = temp% V# k% ~# u( j
  66.     Exit Function
    ; \$ |+ \$ O8 j; i, K6 D* z! |" C
  67. End If
    / q+ x+ [( y: T" }2 {
  68. '以上利用工作表函数VLookup进行精确查找,如果没有查找,将出错,此时将自动进入错误处理段代码* Y& @: W/ x* G8 O
  69. '处理出生日期和性别的代码
    9 u* _$ p5 ]( S  h- _/ {  F
  70. If GetType = 3 Then; q: I1 [3 g$ [. Y  \7 m+ I
  71.     If Len(str) = 15 Then4 u6 e) B4 ^3 q
  72.         GetIDcardInfo = "19" & Mid(str, 7, 2) & "-" & Mid(str, 9, 2) & "-" & Mid(str, 11, 2)
    3 R' i% ~0 V3 _& G" b+ m
  73.     ElseIf Len(str) = 18 Then7 e: V- }/ [3 w9 F6 i+ u; s* @3 V
  74.         GetIDcardInfo = Mid(str, 7, 4) & "-" & Mid(str, 11, 2) & "-" & Mid(str, 13, 2)
    : Y5 r+ o* |3 @  m+ V2 r6 q
  75.     End If8 B; p* X  ^4 j
  76.     Exit Function( `% ^3 \$ @& d( e+ |& h& f
  77. End If2 u+ N4 L& y* |0 C* s/ i
  78. If GetType = 4 Then
    4 M4 \9 T9 _) n. P. w9 R2 {* _
  79.     GetIDcardInfo = VBA.IIf((Mid(str, 15, 3) Mod 2), "男", "女")
    % Q2 `4 P% l5 q$ g3 V8 t
  80.     Exit Function7 v0 C3 k4 X9 x) t( c2 G% o& [. g
  81. End If
    7 q( E7 ^5 d! Y. J) F) l
  82. '处理周岁 获得出生的年月日数据和当前计算机的年月日数据,并全部用val转换为数值,便于比较和计算/ J7 m/ P0 `+ W4 E" p5 T6 r
  83. If GetType = 5 Then
    & V' G2 Y! y" L2 @7 X6 t0 u
  84.     Dim y, m, d As Integer
    1 N7 V) r: |, u! M: N5 H7 E
  85.     If Len(str) = 15 Then5 F8 c* W( W: f! ^4 x! [
  86.         y = Val("19" & Mid(str, 7, 2))
    7 {  ?) d9 T9 D4 S
  87.         m = Val(Mid(str, 9, 2))! j3 W, \' x5 N  z' m' H4 R
  88.         d = Val(Mid(str, 11, 2))
    8 U4 L7 a) w# P4 R
  89.     ElseIf Len(str) = 18 Then
    & f+ j3 x$ a8 |+ r; Q% |" }
  90.         y = Val(Mid(str, 7, 4))
    ( Y9 E9 f- K% y; }
  91.         m = Val(Mid(str, 11, 2))$ \7 L, M( a  F% B9 d+ u
  92.         d = Val(Mid(str, 13, 2))8 p0 {" f# d; b$ ]6 t; r
  93.     End If
    9 P8 j) v& P8 G( q) `
  94.     If Val(Month(Now)) > m Then '当前月份大于出生月份,肯定已经过了生日
    9 y: e/ L" ]5 ~6 v& u" w. k3 \
  95.         temp = Val(Year(Now)) - y
    3 M# D; S+ g; C
  96.     ElseIf Val(Month(Now)) = m And Val(Day(Now)) >= d Then '当前月份和出生月份相等,而且当前日期不小于出生日期,说明正好是生日或者已经过了生日
    & M: O2 B7 n. w' F
  97.         temp = Val(Year(Now)) - y
    & p0 `# o7 `- V9 I0 ^1 J8 w# }: W
  98.     Else                                         '除此之外,没有到生日
    ' P  T% N8 B7 ?
  99.         temp = Val(Year(Now)) - y - 1
    8 B7 o3 E  a( W
  100.     End If
    * B- d( G" @% w
  101.     GetIDcardInfo = temp- p& ?3 s  ~* `6 x+ k0 z
  102.     Exit Function
    8 D" K! m) E/ g2 p" v
  103. End If
    2 _, y/ V* D4 z+ Q% _. n, c
  104. If GetType = 6 Then  '不考虑生日因素时,直接年份相减求年龄
    1 X) [8 f. z. c1 X
  105.     If Len(str) = 15 Then0 L" ?8 l$ ]4 M! ~$ [& q% O
  106.         temp = Val(Year(Now)) - Val("19" & Mid(str, 7, 2))
    % v( q9 j6 s" l( t& O1 i
  107.     ElseIf Len(str) = 18 Then: ]: I* N( S$ `5 s* O* y2 s
  108.         temp = Val(Year(Now)) - Val(Mid(str, 7, 4))2 @7 D4 @5 J8 E1 \+ j
  109.     End If; l1 u! b0 X+ J( @5 Z% H
  110.     GetIDcardInfo = temp
    - x! @" C+ _' f" F4 _% c, g
  111.     Exit Function8 Q/ ]/ V" f( W5 g8 R
  112. End If
    $ j  x+ o$ u" s# Z" g+ [
  113. '处理星座
    ; r3 L6 r+ f+ d" T/ `
  114. If GetType = 7 Then4 l/ t5 b6 X% x
  115.     Dim XZ As Integer 'XZ=出生月*100+出生日,这样转为数值后容易判断和编程
    # m3 ~. F0 N, {7 S
  116.     If Len(str) = 15 Then
    0 s' C) Z( u, n3 _" q. g' Y
  117.         XZ = Val(Mid(str, 9, 2)) * 100 + Val(Mid(str, 11, 2))0 R+ e6 t! Y) E5 U
  118.     ElseIf Len(str) = 18 Then  Q9 [  m0 N9 E6 S+ o& y% u
  119.         XZ = Val(Mid(str, 11, 2)) * 100 + Val(Mid(str, 13, 2))
    $ x  A9 D" X' f
  120.     End If
    2 I! \$ t& Q% H$ m; b. W
  121.     temp = "号码错误"* p  [0 R, u* n2 ^& J6 t
  122.     Select Case XZ
    % @6 k- }+ v& p3 V
  123.     Case 321 To 419
    ; X0 ]* i8 \" [0 N/ h
  124.         temp = "白羊座"+ D6 z: w& H* D
  125.     Case 420 To 5201 ^: V3 A1 y+ c% \- W
  126.         temp = "金牛座"
    # M& K3 h) ^, a& t2 \
  127.     Case 521 To 621
    ! ?% G4 o6 l. h) G" p
  128.         temp = "双子座"7 D- b8 Z) {5 }  y5 B( l
  129.     Case 622 To 722
    0 T+ I! x9 q1 E4 {7 U- w
  130.         temp = "巨蟹座"
    2 X9 y$ n( l9 @  Q0 J! \
  131.     Case 723 To 822! t9 T6 |, a  x) }: z0 t/ A; Z
  132.         temp = "狮子座"
    / z$ I4 Z1 F) L! I) W. [
  133.     Case 823 To 9227 i$ y: ]3 {0 L$ |2 w
  134.         temp = "处女座"7 b+ e6 ~& [/ o, n% A- A
  135.     Case 923 To 1023' u1 N6 Z5 D. [3 ?0 U& n
  136.         temp = "天秤座"# b; m1 t# A9 o' B
  137.     Case 1024 To 1122* M8 Z( n8 E2 o7 p
  138.         temp = "天蝎座"4 Z: H" T0 R1 h5 I
  139.     Case 1123 To 1221
    5 A  b, S' q1 p" n8 V: j# t, N, B
  140.         temp = "射手座". ^; R6 Y6 A6 N+ t) ^0 o& h0 L
  141.     Case 1222 To 1231
    $ H$ z# x$ e; l/ q5 [" {" h% u
  142.         temp = "魔羯座"- P  m- `, ~  k. L& [' t
  143.     Case 101 To 119. k; t; e& C/ v5 m) x$ I# Y! T1 z
  144.         temp = "魔羯座"+ a, o* Z8 C3 T7 d+ G$ d9 H; M
  145.     Case 120 To 218
    / i3 |9 d$ K; E$ {/ q5 I6 O
  146.         temp = "水瓶座"' y9 u, I7 F: v: V9 }: f/ `
  147.     Case 219 To 320
    3 K. ^" {+ q9 f3 L0 G. M( V
  148.         temp = "双鱼座"
      ^& f; z: r6 w" v6 V6 x' j
  149.     End Select
    ) _8 Q2 j6 k) M% d
  150.     GetIDcardInfo = temp9 e, S8 W, j( ~& y
  151.     Exit Function6 X% w, S/ `# i2 R5 o
  152. End If  {) N! m: ]5 S. d- }  a
  153. err: '错理处理( B; {0 b7 n+ E& j7 [
  154. If GetType = 1 Or GetType = 2 Then3 ~6 y: C/ `) F
  155. GetIDcardInfo = "数据库中没有相关信息"
    6 L5 r3 t# C$ k0 ^9 K! Y
  156. Else
    2 m2 [5 e% \8 f6 d5 Z& [
  157. GetIDcardInfo = ""/ t7 B8 X# ?( B. v* `# x0 Q8 N
  158. End If
    / d! e, c0 _2 b" w$ Y
  159. Application.ScreenUpdating = True  '恢复屏幕更新
    2 G: ]4 e6 n4 g5 r: c
  160. End Function
    ; O: J" ^7 U0 Q( E: B% n
复制代码
最后是ET文档:
% s6 N2 W- o/ {6 k6 Z; L* e* N6 s! o/ L% v/ ]4 a& j

0 B6 {5 ]7 \& {0 p, {. U" C

本帖子中包含更多资源

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

已有 2 人评分威望 收起 理由
zhouyiran1@126.com + 15 很给力!
松风水月 + 15 赞一个!

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

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

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

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

该用户从未签到

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

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

发表于 2012-10-21 00:50 |显示全部楼层
本帖最后由 天远 于 2012-10-21 00:54 编辑 4 V+ U% u' [7 h  A7 l/ L
3 V6 |' S# }* K
自己先占个楼说明一下,户口所在地的数据库问题,由于一些行政区的撤消、建立、分割、合并、改名等。我的能力范围内无法获得更新更全的数据库,请大家谅解。+ ^" m6 m1 p7 t2 ]" T2 @, u. q
对于帖子中的新旧两版数据库。
6 f. F. h  l( V% u旧版的数据库中信息量更大,因为保留了一些已经不存在的行政区,但是却使用了一些旧的名字(有些地方早已经改名)。
2 h; c  a# b- ~% e) _- I对于附件中的文档,总共有6个表,大家看到的是后面3个。
9 T# K* R# g0 m! {第1个表存储的是旧版数据库,第2个表存储着新版数据库,第3个表是空表,是我为将来更新的数据库预留的。
热爱分享和学习。希望WPS论坛越办越好,WPS软件越做越好。也希望能在这里交到更多志同道合的朋友。我的邮箱:ypr@yprnet.com
我在WPS论坛上的教程帖子合集: http://blog.yprnet.com/wps
回复

使用道具 举报

153

主题

109

听众

1万

积分

解答支持团长

老菜鸟

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

签到天数: 240 天

[LV.8]以坛为家I

金币
1254
威望
25965
帖子
10314
精华
1

活跃会员奖 解答支持团 测试体验团 乐于助人奖 优秀会员奖

发表于 2012-10-26 15:06 |显示全部楼层
高手一亮相,果然不凡,学习啦!
回复

使用道具 举报

9

主题

22

听众

1万

积分

测试体验团员

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

签到天数: 1153 天

[LV.10]以坛为家III

金币
2125
威望
26226
帖子
6157
精华
0

优秀会员奖 活跃会员奖 乐于助人奖 测试体验团

发表于 2012-10-26 19:27 |显示全部楼层
花了不少功夫吧
回复

使用道具 举报

84

主题

59

听众

3088

积分

测试体验团员

系统分析师

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

该用户从未签到

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

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

发表于 2012-10-26 19:34 |显示全部楼层
zhouyiran1@126.com 发表于 2012-10-26 15:06
7 ~# d# C$ g$ P高手一亮相,果然不凡,学习啦!
, o; d. n; S4 m  h9 }
团长过奖了,要向团长学习
回复

使用道具 举报

1

主题

0

听众

31

积分

LV.1

Rank: 1

该用户从未签到

金币
0
威望
50
帖子
31
精华
0
发表于 2012-11-12 20:02 |显示全部楼层
天远很厉害哦
回复

使用道具 举报

7

主题

0

听众

79

积分

测试体验团员

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

该用户从未签到

金币
35
威望
173
帖子
37
精华
0

测试体验团

发表于 2012-11-13 15:37 |显示全部楼层
我的神儿啊,银才啊
回复

使用道具 举报

0

主题

0

听众

3

积分

LV.1

Rank: 1

该用户从未签到

金币
0
威望
1
帖子
6
精华
0
发表于 2013-4-25 14:38 |显示全部楼层
学习了{:soso_e182:}
回复

使用道具 举报

0

主题

1

听众

374

积分

LV.4

Rank: 4

该用户从未签到

金币
93
威望
870
帖子
183
精华
0
发表于 2013-4-25 14:45 |显示全部楼层
太牛了  
回复

使用道具 举报

0

主题

0

听众

5

积分

LV.1

Rank: 1

该用户从未签到

金币
0
威望
4
帖子
8
精华
0
发表于 2013-4-27 21:21 |显示全部楼层
谢谢,很好
回复

使用道具 举报

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

快速回帖:

fastpost

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

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

Powered by Discuz! X2.5

© 2001-2012 Comsenz Inc.

回顶部