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

maozhe

今日把我压箱底自定义函数拿出来与大家分享，大家要是有什么好的函数或代码也可以拿出来一起研究，共同进步！
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

复制代码

maozhe

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

复制代码

maozhe

7、可以代替lookup函数的四个函数，本人特别推荐大家用Dlookup和Ulookup函数

1. '=Dlookup(查找内容tj，查找区域rg1，待返回数据区域rg2，第M个，默认为0，返回全部，连接字符st，默认为“,”)
   
2. '主要用于按条件将内容一对多的合并，dlookup使用了数组和字典功能，为速度型，
   
3. '参数M默认为0，返回全部信息，你可以随便指定不为0，当为负数时是倒着查第几个，
   
4. '连接符号可以随便更改，不输入时显示默认的英文逗号！也可以通过“”取消连接符号！
   
5. '支持可以从右向左查询，把rg1和rg2换一下位置就可以了
   
6. '使用筛选查询，就是把返回的内容放在不同单元格内分别显示，当条件变化是，单元格内容跟着变化
   
7. 
   
8. Function Dlookup(TJ As Range, RG1 As Range, RG2 As Range, Optional M As Integer = 0, Optional ST As String = ",") As String
   
9.     Dim d As Object, Arr, Brr, crr, ds As String, S As String, i As Integer
   
10.     Arr = RG1.Value
    
11.     Brr = RG2.Value
    
12.     S = TJ.Value
    
13.     If M <> 0 Then ST = "|||"
    
14.     Set d = CreateObject("scripting.dictionary")
    
15.     For i = 1 To UBound(Arr)
    
16.         If Arr(i, 1) = S Then
    
17.             If Not d.Exists(S) Then
    
18.                 d(S) = Brr(i, 1)
    
19.             Else
    
20.                 d(S) = d(S) & ST & Brr(i, 1)
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     ds = d(S) '要是没有M参数，直接写成Dlookup = d(s)结束，结果就是查找所有！
    
25.     Set d = Nothing
    
26.     '有了参数M，才有以下语句，先把字典值分配给变量ds，再由SPLIT函数拆分赋值给变量crr
    
27.     crr = Split(ds, ST)
    
28.     If M = 0 Then '查找所有值
    
29.         Dlookup = ds
    
30.         Exit Function
    
31.     ElseIf M > 0 And M < UBound(crr) + 2 Then '正向查找第几个
    
32.         Dlookup = crr(M - 1)
    
33.         Exit Function
    
34.     ElseIf M < 0 And M > -UBound(crr) - 2 Then  '逆向查找第几个
    
35.         Dlookup = crr(UBound(crr) + M + 1)
    
36.         Exit Function
    
37.     Else '无结果
    
38.         Dlookup = ""
    
39.     End If
    
40. End Function
    
41. 
    
42. 'Ulookup基本功能与Dlookup一样，就是内部不存在重复项而已
    
43. Function Ulookup(TJ As Range, RG1 As Range, RG2 As Range, Optional M As Integer = 0, Optional ST As String = ",") As String
    
44.     Dim d As Object, Arr, Brr, crr, ds As String, S As String, i As Integer
    
45.     Arr = RG1.Value
    
46.     Brr = RG2.Value
    
47.     S = TJ.Value
    
48.     If M <> 0 Then ST = "|||"
    
49.     Set d = CreateObject("scripting.dictionary")
    
50.     For i = 1 To UBound(Arr)
    
51.         If Arr(i, 1) = S Then
    
52.             If Not d.Exists(S) Then
    
53.                 d(S) = Brr(i, 1)
    
54.             Else
    
55.                 If InStr(ST & d(S) & ST, ST & Brr(i, 1) & ST) = 0 Then d(S) = d(S) & ST & Brr(i, 1)
    
56.             End If
    
57.         End If
    
58.     Next
    
59.     ds = d(S) '要是没有M参数，直接写成Ulookup = d(s)结束，结果就是查找所有！
    
60.     Set d = Nothing
    
61.     '有了参数M，才有以下语句，先把字典值分配给变量ds，再由SPLIT函数拆分赋值给变量crr
    
62.     crr = Split(ds, ST)
    
63.     If M = 0 Then '查找所有值
    
64.         Ulookup = ds
    
65.         Exit Function
    
66.     ElseIf M > 0 And M < UBound(crr) + 2 Then '正向查找第几个
    
67.         Ulookup = crr(M - 1)
    
68.         Exit Function
    
69.     ElseIf M < 0 And M > -UBound(crr) - 2 Then  '逆向查找第几个
    
70.         Ulookup = crr(UBound(crr) + M + 1)
    
71.         Exit Function
    
72.     Else '无结果
    
73.         Ulookup = ""
    
74.     End If
    
75. End Function
    

复制代码

maozhe

继续上文

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. 
   
7. Function Mlookup(TJ As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional ST As String = ",") As String
   
8. Dim arr1, ARR2, Ls
   
9. Dim r, k, i As Integer, S As String, Sr As String
   
10. arr1 = TJ.Value
    
11. ARR2 = rgs.Value
    
12. If VBA.IsArray(arr1) Then
    
13. For Each r In arr1
    
14. If r <> "" Then
    
15. S = S & r
    
16. Ls = Ls + 1
    
17. End If
    
18. Next r
    
19. Else
    
20. S = arr1
    
21. End If
    
22. If M > 0 Then '非查找最后一个
    
23. For i = 1 To UBound(ARR2)
    
24. Sr = ""
    
25. If Ls > 1 Then
    
26. For q = 1 To Ls
    
27. Sr = Sr & ARR2(i, q)
    
28. Next q
    
29. Else
    
30. Sr = ARR2(i, 1)
    
31. End If
    
32. If Sr = S Then
    
33. k = k + 1
    
34. If k = M Then
    
35. Mlookup = ARR2(i, L)
    
36. Exit Function
    
37. End If
    
38. End If
    
39. Next i
    
40. ElseIf M = 0 Then '查找所有值
    
41. For i = 1 To UBound(ARR2)
    
42. Sr = ""
    
43. If Ls > 1 Then
    
44. For q = 1 To Ls
    
45. Sr = Sr & ARR2(i, q)
    
46. Next q
    
47. Else
    
48. Sr = ARR2(i, 1)
    
49. End If
    
50. If Sr = S Then
    
51. Mlookup = Mlookup & ST & ARR2(i, L)
    
52. End If
    
53. Next i
    
54. Mlookup = Right(Mlookup, Len(Mlookup) - Len(ST))
    
55. Exit Function
    
56. Else '查找最后一个
    
57. For i = UBound(ARR2) To 1 Step -1
    
58. Sr = ""
    
59. If Ls > 1 Then
    
60. For q = 1 To Ls
    
61. Sr = Sr & ARR2(i, q)
    
62. Next q
    
63. Else
    
64. Sr = ARR2(i, 1)
    
65. End If
    
66. If Sr = S Then
    
67. Mlookup = ARR2(i, L)
    
68. Exit Function
    
69. End If
    
70. Next i
    
71. End If
    
72. Mlookup = ""
    
73. End Function
    
74. 
    
75. '=Wlookup(查找内容，查找区域,返回值所在的列数L,第M个数值，与原数据排列有关,P是否精确查找，默认为0，模糊查找)，
    
76. '用法同Mlookup函数
    
77. Function Wlookup(rg As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional P As Integer = 0)
    
78. Dim arr1, ARR2, arr3, columnn 'columnn是列数
    
79. Dim r, k, x, cc, Sr As String
    
80. arr1 = rg.Value
    
81. If L > 0 Then ARR2 = rgs
    
82. If L < 0 Then
    
83. arr3 = rgs
    
84. ARR2 = rgs.Offset(0, L).Resize(UBound(arr3), UBound(arr3, 2) - L) 'UBound(arr3, 2)是arr3的列数，rgs需要扩展范围，将左侧L列加入其中，如原来是B2:B3，L是-1，那么扩展后就是A2:B3
    
85. End If
    
86. If VBA.IsArray(arr1) Then
    
87. For Each r In arr1
    
88. If r <> "" Then
    
89. cc = cc & r '查找值为多个单元格合并
    
90. columnn = columnn + 1
    
91. End If
    
92. Next r
    
93. Else
    
94. cc = arr1
    
95. End If
    
96. If M > 0 And L > 0 Then '非查找最后一个
    
97. For x = 1 To UBound(ARR2) 'x是数组的行数
    
98. Sr = ""
    
99. If columnn > 1 Then
    
100. For q = 1 To columnn 'q是数组中列的范围
     
101. Sr = Sr & ARR2(x, q)
     
102. Next q
     
103. Else
     
104. Sr = ARR2(x, 1)
     
105. End If
     
106. If P = 0 And Sr = cc Then
     
107. k = k + 1
     
108. If k = M Then
     
109. Wlookup = ARR2(x, L)
     
110. Exit Function
     
111. End If
     
112. End If
     
113. If P = 1 And Sr Like "*" & cc & "*" Then
     
114. k = k + 1
     
115. If k = M Then
     
116. Wlookup = ARR2(x, L)
     
117. Exit Function
     
118. End If
     
119. End If
     
120. Next x
     
121. ElseIf M > 0 And L < 0 Then '非查找最后一个
     
122. For x = 1 To UBound(ARR2) 'x是数组的行数
     
123. Sr = ""
     
124. If columnn > 1 Then
     
125. For q = 1 To columnn 'q是数组中列的范围，查找值是合并的，sr就是指查找值
     
126. Sr = Sr & ARR2(x, q - L) 'rgs已经拓展，查找列所在的位置发生变化，需要加上L列，因L是负数，使用-L转换为正数
     
127. Next q
     
128. Else
     
129. Sr = ARR2(x, 1 - L) '查找值所处的位置，从拓展范围后的rgs数组的最左侧算起，
     
130. End If
     
131. If P = 0 And Sr = cc Then '查找值是单个
     
132. k = k + 1
     
133. If k = M Then
     
134. Wlookup = ARR2(x, 1)
     
135. Exit Function
     
136. End If
     
137. End If
     
138. If P = 1 And Sr Like "*" & cc & "*" Then '查找值是单个
     
139. k = k + 1
     
140. If k = M Then
     
141. Wlookup = ARR2(x, 1)
     
142. Exit Function
     
143. End If
     
144. End If
     
145. Next x
     
146. ElseIf M = 0 And L > 0 Then '查找所有值
     
147. For x = 1 To UBound(ARR2)
     
148. Sr = ""
     
149. If columnn > 1 Then
     
150. For q = 1 To columnn
     
151. Sr = Sr & ARR2(x, q)
     
152. Next q
     
153. Else
     
154. Sr = ARR2(x, 1)
     
155. End If
     
156. If P = 0 And Sr = cc Then
     
157. Wlookup = Wlookup & "," & ARR2(x, L)
     
158. End If
     
159. If P = 1 And Sr Like "*" & cc & "*" Then
     
160. Wlookup = Wlookup & "," & ARR2(x, L)
     
161. End If
     
162. Next x
     
163. Wlookup = Right(Wlookup, Len(Wlookup) - 1)
     
164. Exit Function
     
165. ElseIf M = 0 And L < 0 Then '查找所有值
     
166. For x = 1 To UBound(ARR2)
     
167. Sr = ""
     
168. If columnn > 1 Then
     
169. For q = 1 To columnn
     
170. Sr = Sr & ARR2(x, q - L)
     
171. Next q
     
172. Else
     
173. Sr = ARR2(x, 1 - L)
     
174. End If
     
175. If P = 0 And Sr = cc Then
     
176. Wlookup = Wlookup & "," & ARR2(x, 1)
     
177. End If
     
178. If P = 1 And Sr Like "*" & cc & "*" Then
     
179. Wlookup = Wlookup & "," & ARR2(x, 1)
     
180. End If
     
181. Next x
     
182. Wlookup = Right(Wlookup, Len(Wlookup) - 1)
     
183. Exit Function
     
184. Else '查找最后一个
     
185. If L > 0 And M = -1 Then
     
186. For x = UBound(ARR2) To 1 Step -1
     
187. Sr = ""
     
188. If columnn > 1 Then
     
189. For q = 1 To columnn
     
190. Sr = Sr & ARR2(x, q)
     
191. Next q
     
192. Else
     
193. Sr = ARR2(x, 1)
     
194. End If
     
195. If P = 0 And Sr = cc Then
     
196. Wlookup = ARR2(x, L)
     
197. Exit Function
     
198. End If
     
199. If P = 1 And Sr Like "*" & cc & "*" Then
     
200. Wlookup = ARR2(x, L)
     
201. Exit Function
     
202. End If
     
203. Next x
     
204. End If
     
205. If L < 0 And M = -1 Then
     
206. For x = UBound(ARR2) To 1 Step -1
     
207. Sr = ""
     
208. If columnn > 1 Then
     
209. For q = 1 To columnn
     
210. Sr = Sr & ARR2(x, q - L)
     
211. Next q
     
212. Else
     
213. Sr = ARR2(x, 1 - L)
     
214. End If
     
215. If P = 0 And Sr = cc Then
     
216. Wlookup = ARR2(x, 1)
     
217. Exit Function
     
218. End If
     
219. If P = 1 And Sr Like "*" & cc & "*" Then
     
220. Wlookup = ARR2(x, 1)
     
221. Exit Function
     
222. End If
     
223. Next x
     
224. End If
     
225. End If
     
226. Wlookup = ""
     
227. End Function

复制代码

maozhe

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

YZC51

不错！建议给出原文出处！

YZC51

试试
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

浮生若梦~~~

楼主辛苦了,若能附上每个函数的用法就好了

niko88819

一一收藏谢楼主提供分享 !!!

maozhe

'人民币金额大写函数
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