ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 509|回复: 12

我的自定义函数库——压箱底的宝贝拿出来跟大家分享一下!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-21 01:22 | 显示全部楼层 |阅读模式
今日把我压箱底自定义函数拿出来与大家分享,大家要是有什么好的函数或代码也可以拿出来一起研究,共同进步!
1、财务专用人民币大写
  1. '人民币金额大写函数
  2. Function dx(M)
  3.     dx = (IIf(Abs(M) < 0.005, "", Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 00")), Split("@ [DBNum2];;0 [>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分")), ""), "零分", "整"), "0圆零", ""), "0圆", "")))
  4. End Function
复制代码
2、自定义MINIF函数-提取区域内大于 Z 最小值(Maxif类似)
  1. Function Minif(RNG As Range, Optional Z = 0)
  2.     Dim temp
  3.     ar = RNG.Value
  4.     temp = Application.Max(ar)
  5.     For Each c In ar
  6.         If Val(c) > Z Then
  7.             If c < temp Then temp = c
  8.         End If
  9.     Next
  10.     Minif = temp
  11. End Function
  12. '自定义MINIF函数-提取区域内大于 Z 最大值
  13. Function Maxif(RNG As Range, Optional Z = 0)
  14.     Dim temp
  15.     ar = RNG.Value
  16.     temp = Application.Min(ar)
  17.     For Each c In ar
  18.         If Val(c) < Z Then
  19.             If c > temp Then temp = c
  20.         End If
  21.     Next
  22.     Maxif = temp
  23. End Function
复制代码
3、结合微软iferror函数,自创ifnul和ifblank函数
  1. 'IFNULL类似IFERROR(a,b)函数,a空为b
  2. Function IFNULL(Rng1 As Range, Rng2 As Range) As String
  3.     Dim Var1, Var2
  4.     Var1 = Rng1.Value
  5.     Var2 = Rng2.Value
  6.     If Var1 = "" Then
  7.         IFNULL = Var2
  8.     Else
  9.         IFNULL = Var1
  10.     End If
  11. End Function
  12. 'IFBLANK类似IFNULL(a,b)函数,a空为b
  13. Function IFBLANK(Rng1 As Range, Rng2 As Range) As String
  14.     Dim Var1, Var2
  15.     Var1 = Rng1.Value
  16.     Var2 = Rng2.Value
  17.     If Trim(Var1) = "" Then
  18.         IFBLANK = Var2
  19.     Else
  20.         IFBLANK = Var1
  21.     End If
  22. End Function
复制代码




TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 01:26 | 显示全部楼层
4、会计专用数据处理模式,如20万元,57.05亿元,和数字大写功能
  1. '选项为w,w1,w2,y,y1,y2,d
  2. Function Jine(M, Optional jian As String = "")   '200个字符
  3.     If jian = "W" Or jian = "w" Then
  4.         Jine = Format(Round(M * 0.0001, 0), "#,##0") & "万元"
  5.     ElseIf jian = "Y" Or jian = "y" Then
  6.         Jine = Format(Round(M * 0.00000001, 0), "#,##0") & "亿元"
  7.     ElseIf jian = "W1" Or jian = "w1" Then
  8.         Jine = Format(Round(M * 0.0001, 1), "#,##0.0") & "万元"
  9.     ElseIf jian = "Y1" Or jian = "y1" Then
  10.         Jine = Format(Round(M * 0.00000001, 1), "#,##0.0") & "亿元"
  11.     ElseIf jian = "W2" Or jian = "w2" Then
  12.         Jine = Format(Round(M * 0.0001, 2), "#,##0.00") & "万元"
  13.     ElseIf jian = "Y2" Or jian = "y2" Then
  14.         Jine = Format(Round(M * 0.00000001, 2), "#,##0.00") & "亿元"
  15.     ElseIf jian = "D" Or jian = "d" Then
  16.         Jine = "人民币" & (IIf(Abs(M) < 0.005, "", Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 00")), Split("@ [DBNum2];;0 [>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分")), ""), "零分", "整"), "0圆零", ""), "0圆", "")))
  17.     Else
  18.         Jine = IIf(Abs(M) < 0.005, "", Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 00")), Split("@ [DBNum2];;0 [>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分")), ""), "零分", "整"), "0圆零", ""), "0圆", ""))
  19.     End If
  20. End Function
复制代码
5、会计专用公式余额公式,第四个参Total数表示可以忽略本期借贷方累计金额
  1. Function YUE(YUE0 As Range, JF As Range, DF As Range, Optional Total As String = 0) As Double
  2.     Dim Var0, Var1, Var2
  3.     Var0 = Val(YUE0.Value)
  4.     Var1 = Val(JF.Value)
  5.     Var2 = Val(DF.Value)
  6.     If Total = 0 Then
  7.         If IsNumeric(Var0) Then
  8.             YUE = Round(Var0 + Var1 - Var2, 2)
  9.         Else
  10.             YUE = Round(Var1 - Var2, 2)
  11.         End If
  12.     Else
  13.         If IsNumeric(Var0) Then
  14.             If IsNumeric(Var1) And IsNumeric(Var2) And Var1 <> 0 And Var2 <> 0 Then
  15.                 YUE = Round(Var0, 2)
  16.             Else
  17.                 YUE = Round(Var0 + Var1 - Var2, 2)
  18.             End If
  19.         Else
  20.             YUE = Round(Var1 - Var2, 2)
  21.         End If
  22.     End If
  23. End Function
复制代码
6、身份证信息函数
  1. '第一个参数,目标单元格!
  2. '第二个参数选项:出生日期:csrq,出生年月日:csnyr,出生年月:csny,出生年:csn,年龄:nl,性别:xb,无参数,检查身份证长度是否有误!

  3. Function sfz(RNG As Range, Optional S As String = "csrq") As String
  4.     If Len(RNG) <> 18 Then
  5.         sfz = "SFZ长度错误"
  6.     ElseIf (Mid(RNG, 11, 2) > 12) Or (Mid(RNG, 13, 2) > 31) Then
  7.         sfz = "SFZ日期错误"
  8.     ElseIf S = "csrq" Then
  9.         sfz = Application.Text(Mid(RNG, 7, 8), "0000-00-00")
  10.         ElseIf S = "csnyr" Then
  11.         sfz = Application.Text(Mid(RNG, 7, 8), "0000年00月00日")
  12.     ElseIf S = "csny" Then
  13.         sfz = Application.Text(Mid(RNG, 7, 6), "0000年00月")
  14.     ElseIf S = "csn" Then
  15.         sfz = Application.Text(Mid(RNG, 7, 4), "0000年")
  16.     ElseIf S = "nl" Then
  17.         sfz = Year(Now()) - (19 & Mid(RNG, Len(RNG) / 2, 2)) & "岁"
  18.     ElseIf S = "xb" Then
  19.         sfz = IIf(Mid(RNG, 17, 1) Mod 2, "男", "女")
  20.     Else
  21.         sfz = "参数错误"
  22.     End If
  23. End Function
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 01:28 | 显示全部楼层
7、可以代替lookup函数的四个函数,本人特别推荐大家用Dlookup和Ulookup函数
  1. '=Dlookup(查找内容tj,查找区域rg1,待返回数据区域rg2,第M个,默认为0,返回全部,连接字符st,默认为“,”)
  2. '主要用于按条件将内容一对多的合并,dlookup使用了数组和字典功能,为速度型,
  3. '参数M默认为0,返回全部信息,你可以随便指定不为0,当为负数时是倒着查第几个,
  4. '连接符号可以随便更改,不输入时显示默认的英文逗号!也可以通过“”取消连接符号!
  5. '支持可以从右向左查询,把rg1和rg2换一下位置就可以了
  6. '使用筛选查询,就是把返回的内容放在不同单元格内分别显示,当条件变化是,单元格内容跟着变化

  7. Function Dlookup(TJ As Range, RG1 As Range, RG2 As Range, Optional M As Integer = 0, Optional ST As String = ",") As String
  8.     Dim d As Object, Arr, Brr, crr, ds As String, S As String, i As Integer
  9.     Arr = RG1.Value
  10.     Brr = RG2.Value
  11.     S = TJ.Value
  12.     If M <> 0 Then ST = "|||"
  13.     Set d = CreateObject("scripting.dictionary")
  14.     For i = 1 To UBound(Arr)
  15.         If Arr(i, 1) = S Then
  16.             If Not d.Exists(S) Then
  17.                 d(S) = Brr(i, 1)
  18.             Else
  19.                 d(S) = d(S) & ST & Brr(i, 1)
  20.             End If
  21.         End If
  22.     Next
  23.     ds = d(S) '要是没有M参数,直接写成Dlookup = d(s)结束,结果就是查找所有!
  24.     Set d = Nothing
  25.     '有了参数M,才有以下语句,先把字典值分配给变量ds,再由SPLIT函数拆分赋值给变量crr
  26.     crr = Split(ds, ST)
  27.     If M = 0 Then '查找所有值
  28.         Dlookup = ds
  29.         Exit Function
  30.     ElseIf M > 0 And M < UBound(crr) + 2 Then '正向查找第几个
  31.         Dlookup = crr(M - 1)
  32.         Exit Function
  33.     ElseIf M < 0 And M > -UBound(crr) - 2 Then  '逆向查找第几个
  34.         Dlookup = crr(UBound(crr) + M + 1)
  35.         Exit Function
  36.     Else '无结果
  37.         Dlookup = ""
  38.     End If
  39. End Function

  40. 'Ulookup基本功能与Dlookup一样,就是内部不存在重复项而已
  41. Function Ulookup(TJ As Range, RG1 As Range, RG2 As Range, Optional M As Integer = 0, Optional ST As String = ",") As String
  42.     Dim d As Object, Arr, Brr, crr, ds As String, S As String, i As Integer
  43.     Arr = RG1.Value
  44.     Brr = RG2.Value
  45.     S = TJ.Value
  46.     If M <> 0 Then ST = "|||"
  47.     Set d = CreateObject("scripting.dictionary")
  48.     For i = 1 To UBound(Arr)
  49.         If Arr(i, 1) = S Then
  50.             If Not d.Exists(S) Then
  51.                 d(S) = Brr(i, 1)
  52.             Else
  53.                 If InStr(ST & d(S) & ST, ST & Brr(i, 1) & ST) = 0 Then d(S) = d(S) & ST & Brr(i, 1)
  54.             End If
  55.         End If
  56.     Next
  57.     ds = d(S) '要是没有M参数,直接写成Ulookup = d(s)结束,结果就是查找所有!
  58.     Set d = Nothing
  59.     '有了参数M,才有以下语句,先把字典值分配给变量ds,再由SPLIT函数拆分赋值给变量crr
  60.     crr = Split(ds, ST)
  61.     If M = 0 Then '查找所有值
  62.         Ulookup = ds
  63.         Exit Function
  64.     ElseIf M > 0 And M < UBound(crr) + 2 Then '正向查找第几个
  65.         Ulookup = crr(M - 1)
  66.         Exit Function
  67.     ElseIf M < 0 And M > -UBound(crr) - 2 Then  '逆向查找第几个
  68.         Ulookup = crr(UBound(crr) + M + 1)
  69.         Exit Function
  70.     Else '无结果
  71.         Ulookup = ""
  72.     End If
  73. End Function
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 01:29 | 显示全部楼层
继续上文

  1. '=Mlookup(查找内容tj,查找区域rgs,返回值所在的列数L,第M个,连接字符串,默认为“,”)
  2. '1、查找内容:除了单个值外,还可以选取多个单元格,进行多条件查找。
  3. '2、查找区域: 同VLOOKUP
  4. '3、返回值的在列数L: 同VLOOKUP
  5. '4、第M个:值为1就返回第1个符合条件的,值为2就返回第2个符合条件的....当值为-1值时,返回最后1个符合条件的值,值为0时返回所有查找结果并用逗号连接

  6. Function Mlookup(TJ As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional ST As String = ",") As String
  7. Dim arr1, ARR2, Ls
  8. Dim r, k, i As Integer, S As String, Sr As String
  9. arr1 = TJ.Value
  10. ARR2 = rgs.Value
  11. If VBA.IsArray(arr1) Then
  12. For Each r In arr1
  13. If r <> "" Then
  14. S = S & r
  15. Ls = Ls + 1
  16. End If
  17. Next r
  18. Else
  19. S = arr1
  20. End If
  21. If M > 0 Then '非查找最后一个
  22. For i = 1 To UBound(ARR2)
  23. Sr = ""
  24. If Ls > 1 Then
  25. For q = 1 To Ls
  26. Sr = Sr & ARR2(i, q)
  27. Next q
  28. Else
  29. Sr = ARR2(i, 1)
  30. End If
  31. If Sr = S Then
  32. k = k + 1
  33. If k = M Then
  34. Mlookup = ARR2(i, L)
  35. Exit Function
  36. End If
  37. End If
  38. Next i
  39. ElseIf M = 0 Then '查找所有值
  40. For i = 1 To UBound(ARR2)
  41. Sr = ""
  42. If Ls > 1 Then
  43. For q = 1 To Ls
  44. Sr = Sr & ARR2(i, q)
  45. Next q
  46. Else
  47. Sr = ARR2(i, 1)
  48. End If
  49. If Sr = S Then
  50. Mlookup = Mlookup & ST & ARR2(i, L)
  51. End If
  52. Next i
  53. Mlookup = Right(Mlookup, Len(Mlookup) - Len(ST))
  54. Exit Function
  55. Else '查找最后一个
  56. For i = UBound(ARR2) To 1 Step -1
  57. Sr = ""
  58. If Ls > 1 Then
  59. For q = 1 To Ls
  60. Sr = Sr & ARR2(i, q)
  61. Next q
  62. Else
  63. Sr = ARR2(i, 1)
  64. End If
  65. If Sr = S Then
  66. Mlookup = ARR2(i, L)
  67. Exit Function
  68. End If
  69. Next i
  70. End If
  71. Mlookup = ""
  72. End Function

  73. '=Wlookup(查找内容,查找区域,返回值所在的列数L,第M个数值,与原数据排列有关,P是否精确查找,默认为0,模糊查找),
  74. '用法同Mlookup函数
  75. Function Wlookup(rg As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional P As Integer = 0)
  76. Dim arr1, ARR2, arr3, columnn 'columnn是列数
  77. Dim r, k, x, cc, Sr As String
  78. arr1 = rg.Value
  79. If L > 0 Then ARR2 = rgs
  80. If L < 0 Then
  81. arr3 = rgs
  82. ARR2 = rgs.Offset(0, L).Resize(UBound(arr3), UBound(arr3, 2) - L) 'UBound(arr3, 2)是arr3的列数,rgs需要扩展范围,将左侧L列加入其中,如原来是B2:B3,L是-1,那么扩展后就是A2:B3
  83. End If
  84. If VBA.IsArray(arr1) Then
  85. For Each r In arr1
  86. If r <> "" Then
  87. cc = cc & r '查找值为多个单元格合并
  88. columnn = columnn + 1
  89. End If
  90. Next r
  91. Else
  92. cc = arr1
  93. End If
  94. If M > 0 And L > 0 Then '非查找最后一个
  95. For x = 1 To UBound(ARR2) 'x是数组的行数
  96. Sr = ""
  97. If columnn > 1 Then
  98. For q = 1 To columnn 'q是数组中列的范围
  99. Sr = Sr & ARR2(x, q)
  100. Next q
  101. Else
  102. Sr = ARR2(x, 1)
  103. End If
  104. If P = 0 And Sr = cc Then
  105. k = k + 1
  106. If k = M Then
  107. Wlookup = ARR2(x, L)
  108. Exit Function
  109. End If
  110. End If
  111. If P = 1 And Sr Like "*" & cc & "*" Then
  112. k = k + 1
  113. If k = M Then
  114. Wlookup = ARR2(x, L)
  115. Exit Function
  116. End If
  117. End If
  118. Next x
  119. ElseIf M > 0 And L < 0 Then '非查找最后一个
  120. For x = 1 To UBound(ARR2) 'x是数组的行数
  121. Sr = ""
  122. If columnn > 1 Then
  123. For q = 1 To columnn 'q是数组中列的范围,查找值是合并的,sr就是指查找值
  124. Sr = Sr & ARR2(x, q - L) 'rgs已经拓展,查找列所在的位置发生变化,需要加上L列,因L是负数,使用-L转换为正数
  125. Next q
  126. Else
  127. Sr = ARR2(x, 1 - L) '查找值所处的位置,从拓展范围后的rgs数组的最左侧算起,
  128. End If
  129. If P = 0 And Sr = cc Then '查找值是单个
  130. k = k + 1
  131. If k = M Then
  132. Wlookup = ARR2(x, 1)
  133. Exit Function
  134. End If
  135. End If
  136. If P = 1 And Sr Like "*" & cc & "*" Then '查找值是单个
  137. k = k + 1
  138. If k = M Then
  139. Wlookup = ARR2(x, 1)
  140. Exit Function
  141. End If
  142. End If
  143. Next x
  144. ElseIf M = 0 And L > 0 Then '查找所有值
  145. For x = 1 To UBound(ARR2)
  146. Sr = ""
  147. If columnn > 1 Then
  148. For q = 1 To columnn
  149. Sr = Sr & ARR2(x, q)
  150. Next q
  151. Else
  152. Sr = ARR2(x, 1)
  153. End If
  154. If P = 0 And Sr = cc Then
  155. Wlookup = Wlookup & "," & ARR2(x, L)
  156. End If
  157. If P = 1 And Sr Like "*" & cc & "*" Then
  158. Wlookup = Wlookup & "," & ARR2(x, L)
  159. End If
  160. Next x
  161. Wlookup = Right(Wlookup, Len(Wlookup) - 1)
  162. Exit Function
  163. ElseIf M = 0 And L < 0 Then '查找所有值
  164. For x = 1 To UBound(ARR2)
  165. Sr = ""
  166. If columnn > 1 Then
  167. For q = 1 To columnn
  168. Sr = Sr & ARR2(x, q - L)
  169. Next q
  170. Else
  171. Sr = ARR2(x, 1 - L)
  172. End If
  173. If P = 0 And Sr = cc Then
  174. Wlookup = Wlookup & "," & ARR2(x, 1)
  175. End If
  176. If P = 1 And Sr Like "*" & cc & "*" Then
  177. Wlookup = Wlookup & "," & ARR2(x, 1)
  178. End If
  179. Next x
  180. Wlookup = Right(Wlookup, Len(Wlookup) - 1)
  181. Exit Function
  182. Else '查找最后一个
  183. If L > 0 And M = -1 Then
  184. For x = UBound(ARR2) To 1 Step -1
  185. Sr = ""
  186. If columnn > 1 Then
  187. For q = 1 To columnn
  188. Sr = Sr & ARR2(x, q)
  189. Next q
  190. Else
  191. Sr = ARR2(x, 1)
  192. End If
  193. If P = 0 And Sr = cc Then
  194. Wlookup = ARR2(x, L)
  195. Exit Function
  196. End If
  197. If P = 1 And Sr Like "*" & cc & "*" Then
  198. Wlookup = ARR2(x, L)
  199. Exit Function
  200. End If
  201. Next x
  202. End If
  203. If L < 0 And M = -1 Then
  204. For x = UBound(ARR2) To 1 Step -1
  205. Sr = ""
  206. If columnn > 1 Then
  207. For q = 1 To columnn
  208. Sr = Sr & ARR2(x, q - L)
  209. Next q
  210. Else
  211. Sr = ARR2(x, 1 - L)
  212. End If
  213. If P = 0 And Sr = cc Then
  214. Wlookup = ARR2(x, 1)
  215. Exit Function
  216. End If
  217. If P = 1 And Sr Like "*" & cc & "*" Then
  218. Wlookup = ARR2(x, 1)
  219. Exit Function
  220. End If
  221. Next x
  222. End If
  223. End If
  224. Wlookup = ""
  225. End Function
复制代码


评分

参与人数 3鲜花 +4 收起 理由
WYS67 + 1
niko88819 + 1 优秀作品
zpy2 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 01:30 | 显示全部楼层
本帖最后由 maozhe 于 2019-12-21 01:45 编辑

超越LOOKUP的函数案例在http://club.excelhome.net/forum. ... ;page=2#pid10183085
17楼,大家可以下载下来慢慢研究!

TA的精华主题

TA的得分主题

发表于 2019-12-21 07:07 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-21 07:49 | 显示全部楼层
本帖最后由 YZC51 于 2019-12-21 08:22 编辑

试试
Function d1x(M)
    If Abs(M) < 0.005 Then d1x = "": Exit Function
    gs = Split("@ [DBNum2];;0 [>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分")
    tt1 = Application.Text(Split(Format(M, " 0. 00")), gs)
    tt = Join(tt1, "")
    fh = IIf(Abs(M) < 0, "负", "")
    d1x = fh & Replace(Replace(Replace(tt, "零分", "整"), "0圆零", ""), "0圆", "")
End Function

评分

参与人数 1鲜花 +1 收起 理由
niko88819 + 1 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-21 09:07 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-21 11:54 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-12 10:22 | 显示全部楼层
'人民币金额大写函数
Function DX(M)
    a = (IIf(Abs(M) < 0.005, "", Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 00")), Split("@ [DBNum2];;0 [>9][dbnum2]圆0角0分;[=0]圆整;[dbnum2]圆零0分")), ""), "零分", "整"), "0圆零", ""), "0圆", "")))
    If M > 0 Then
        DX = a
    ElseIf M = 0 Then
        DX = "零元整"
    Else
        DX = "负" & Replace(a, "-", "")
    End If
End Function

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-4-9 09:42 , Processed in 0.075254 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表