本贴搜集整理一些比较有用的自定义函数

Function eva(Rng As Range) '带备注公式变计算结果 [长]1*[宽]2*[高]3
Set x = CreateObject("MSScriptControl.ScriptControl")
x.Language = "vbscript"
With CreateObject("VBSCRIPT.REGEXP")
.Global = True
.Pattern = "\[.*?\]|{(.*?)}|[^0-9.+-/^*()]"
eva = x.Eval(.Replace(Rng.Text, "$1"))
End With
End Function

同一单元格返回多个符合条件值的MLookup
Function MLookup(val, array1 As Range, array2 As Range, f As Byte) As String
'val 为要查找的值
'array1 要在其中查找的矩形区域,可单列(行) 或多行多列
'array2 是要返回相应值的与array1等大的矩形区域
'f 为0时精确查找,为1时模糊查找
Dim c As Range, FirstAddress As String
With array1
Set c = .Find(val, .Cells(.Count), xlValues, f + 1)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
MLookup = MLookup & "," & array2.Cells(c.Row - .Row + 1, c.Column - .Column + 1).Text
Set c = .Find(val, c, xlValues, f + 1)
Loop Until c.Address = FirstAddress
End If
MLookup = Mid(MLookup, 2)
End With
End Function

Public Function xiaoxie(cJine As String) '大写人民币转小写
Dim i As Byte, t$, n As Byte, w As Byte, f As Integer
i = 0
f = IIf(Left(cJine, 1) = "负", -1, 1)
Do While cJine <> ""
i = i + 1
t = Left(cJine, 1)
n = InStr("壹贰叁肆伍陆柒捌玖", t)
If n > 0 Then
w = InStr("分角元拾佰仟", Mid(cJine, 2, 1))
If w > 0 Then
xiaoxie = xiaoxie + n * 10 ^ (w - 3)
cJine = Mid(cJine, 3)
Else
xiaoxie = xiaoxie + n
cJine = Mid(cJine, 2)
End If
ElseIf InStr("亿万元", t) > 0 Then
xiaoxie = xiaoxie * 10 ^ IIf(Left(cJine, 1) = "元", 0, IIf(InStr(cJine, "万") = 0 And Left(cJine, 1) = "亿", 8, 4))
cJine = Mid(cJine, 2)
Else
cJine = Mid(cJine, 2)
End If
Loop
xiaoxie = xiaoxie * f
End Function

Function countv(x As Range, y As String, z) As Integer '可见单元格条件计数
Set x = Application.Intersect(x.Parent.UsedRange, x)
If Not IsNumeric(z) Then z = """" & z & """"
With x
For r = 1 To .Rows.Count
If Not .Rows(r).EntireRow.Hidden Then
For c = 1 To .Columns.Count
t = .Cells(r, c).value
If Not IsNumeric(t) Then t = """" & t & """"
If Application.Evaluate(t & y & z) Then countv = countv + 1
Next
End If
Next
End With
End Function

天这么好的帖子居然藏起来，为什么不给我们看啊

太高深……

给跪了！！！

我也来增加一些。原创
Function rr(str As String, pat As String, newStr As String)
Application.Volatile
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = pat
rr = .Replace(str, newStr)
End With
End Function
用法如图：

小写转大写。原创
代码秒删，发个图上来先。

大写转小写。非原创
Function DxToN(ss) '大写金额转小写
For i% = 1 To 9
ss = Replace(ss, Mid("壹贰叁肆伍陆柒捌玖", i, 1), i)
ss = Replace(ss, Mid("一二三四五六七八九", i, 1), i)
Next
For i% = Len(ss) To 1 Step -1
s$ = Mid$(ss, i, 1)
X% = InStr("分角圆拾佰仟万拾佰仟亿拾佰仟兆", s)
If X = 0 Then X% = InStr("分毛元十百千万十百千亿十百千兆", s)
If X = 0 Then X% = InStr("分毛块十百千万十百千亿十百千兆", s)
If X Then j% = IIf(j% < X, X, ((j - 3) \ 4) * 4 + X)
If Val(s) Then m
# = m#
+ (s & String(j - 1, "0")) / 100
Next
DxToN = Round(m, 2)
If InStr(ss, "-") Or InStr(ss, "负") Then DxToN = -DxToN
End Function

天啊，，，，，我这小白，，看不懂，。。好可怜