共享一组实用的自定义函数

doitbest

程序语言中的函数和数学中的函数基本概念是相似的。程序语言中的函数也有参数和返回值，以及定义和调用。程序中的函数，就是将一些程序语句结合在一起的部件，通过多次调用，函数可以不止一次地在程序中运行。

程序中使用函数的好处：

一是将大问题分解成许多小问题。函数可以将程序分成多个子程序段，开发者可以独立编写各个子程序，实现程序开发流程的分解。每个函数实现特定功能，我们可以针对这个函数来编写程序。计算机程序中，函数的实现千变万化。函数调用中，即使函数的实现改变了，只要函数的调用方式不变，调用它的程序就不用做任何改变。这种函数调用的结构，使得主程序精巧明了，使程序修改更加容易，程序结构变得具有一种排列紧凑、疏密得当的美感。

二是便于检测错误。一个函数写好后，我们会检测其实现的正确性。程序由多个函数组成的，我们确定每一个函数是正确后，总程序出错的可能性就会降低。另外函数的代码量小，也便于检测错误。

三是实现封装和重用。“封装”的意思是隐藏细节，应用时只需要传递相应的参数给函数，函数就会返回相应的结果，而不必关注函数操作的具体实现。“重用”的特点体现在，各个程序都可以直接调用已经写好的函数，而不用重复编写代码，这种重用提高了程序开发效率。

四是便于维护。每个函数都必须要有清楚的界面和注释，包含了功能，输入的参数、返回值的解释等。让人知道如何调用这个函数。

实际上，系统提供的函数与用户自定义函数本质上是一样的，只是前者显得更专业，速度可能快一些罢了。

对于EXCEL—VBA来说，代码往往是短小精悍的，自定义函数就非必须。但中等以上的代码量也很常见，自定义函数就能够体现出其价值。而且，从成为一个资深代码开发者的标准来看，自定义函数的知识储备与应用习惯的培养，也是必须的。

以下和大家分享一组自认为实用价值较高的自定义函数，当然函数代码仍有进一步优化的余地，这里只是抛砖引玉，开启思路，谨供参考。函数中的说明语句如果不够明确，可结合示例文件加深理解。

doitbest

1、字典排序程序和字典排序数组
字典排序本质上也就是数组排序，但由于其有自己的特点和特殊应用，因此单独写了字典排序程序和函数。字典排序程序是带参数的程序，本质上仍是函数，调用执行后字典将处于排序后的状态。字典排序函数是将排序后的字典写入数组，方便下步调用。
Public Function sortdictoarr(d, key, order)
Rem 将排序后的字典写入数组
Rem 参数1为字典对象，参数2为排序关键字（1为字典键，2为字典值），参数3为升降序种类（1为升序，2为降序）
Dim ar, brr(), tmp0, tmp1, tmp2, ii, i, code, quot
ke = d.keys
it = d.items
If key = 1 Then ar = ke Else ar = it
If order = 1 Then code = "<" Else code = ">"
ReDim brr(1 To d.count, 1 To 2)
For i = 0 To UBound(ar) - 1
    For ii = i + 1 To UBound(ar)
        If TypeName(ar(0)) = "String" Then quot = Chr(34) Else quot = ""
        tmp = Evaluate(quot & ar(ii) & quot & code & quot & ar(i) & quot)
        If tmp = True Then
            tmp0 = ar(i): ar(i) = ar(ii): ar(ii) = tmp0
            tmp1 = it(i): it(i) = it(ii): it(ii) = tmp1
            tmp2 = ke(i): ke(i) = ke(ii): ke(ii) = tmp2
        End If
    Next
Next
For i = 0 To UBound(ke)
    brr(i + 1, 1) = ke(i)
    brr(i + 1, 2) = it(i)
Next
sortdictoarr = brr
End Function

Public Sub sortdic(d, key, order)
Rem 字典排序程序
Rem 参数1为字典对象，参数2为排序关键字（1为字典键，2为字典值），参数3为升降序种类（1为升序，2为降序）
Dim ar, tmp0, tmp1, tmp2, ii, i, code, quot
ke = d.keys
it = d.items
If key = 1 Then ar = ke Else ar = it
If order = 1 Then code = "<" Else code = ">"
For i = 0 To UBound(ar) - 1
    For ii = i + 1 To UBound(ar)
        If TypeName(ar(0)) = "String" Then quot = Chr(34) Else quot = ""
        tmp = Evaluate(quot & ar(ii) & quot & code & quot & ar(i) & quot)
        If tmp = True Then
            tmp0 = ar(i): ar(i) = ar(ii): ar(ii) = tmp0
            tmp1 = it(i): it(i) = it(ii): it(ii) = tmp1
            tmp2 = ke(i): ke(i) = ke(ii): ke(ii) = tmp2
        End If
    Next
Next
d.RemoveAll
For i = 0 To UBound(ke) '将排序后的数组重新写入字典
    d(ke(i)) = it(i)
Next
End Sub

doitbest

2、数组排序函数
VBA没有为我们提供数组排序功能，这是一个缺憾。实际开发中，人们或者书写冗长的排序语句，或者干脆用单元格排序语句来变通代替，也可勉强解决问题，二者的弊端显而易见。此函数可实现最多三个关键字的排序，基本满足实战需要。如有更多关键字排序需求的，可根据此代码思路，进一步深化函数的功能。
Public Function sortarr(arr, key1, order1, Optional key2 = 0, Optional order2 = 1, Optional key3 = 0, Optional order3 = 1)
Rem 数组排序函数
Rem arr为被排序数组，含key参数为排序字段，含order参数为排序次序，key和order两两一组，最多三组，最多可对三个字段排序，后两组排序参数可省略
Dim i, ii, c, code, tmp, code1, code2, tmparr(), v1, v2, v3, v4, v5, v6, tmp0, tmp1, tmp2, tmp3, tmp4
If LBound(arr) = 0 Then
Rem 一维数组排序
    If order1 = 1 Then code = "<" Else code = ">"
    For i = 0 To UBound(arr) - 1
        For ii = i + 1 To UBound(arr)
            tmp = Evaluate(arr(ii) & code & arr(i))
            If tmp = True Then tmp1 = arr(i): arr(i) = arr(ii): arr(ii) = tmp1
        Next
    Next
Else
Rem 二维数组排序
    ReDim tmparr(1 To UBound(arr, 2))
   
    If key2 = 0 And key3 = 0 Then
    Rem 一个关键字排序
        If order1 = 1 Then code1 = "<" Else code1 = ">"
        For i = 1 To UBound(arr) - 1
            For ii = i + 1 To UBound(arr)
                v1 = arr(ii, key1): v2 = arr(i, key1)
                'evaluate括号中的字符串两面要加引号
                If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"
                If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"
                tmp = Evaluate(v1 & code1 & v2)
                If tmp = True Then
                    For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next
                    For c = 1 To UBound(arr, 2): arr(i, c) = arr(ii, c): Next
                    For c = 1 To UBound(arr, 2): arr(ii, c) = tmparr(c): Next
                End If
            Next
        Next
    ElseIf key2 <> 0 And key3 = 0 Then
    Rem 两个关键字排序
        If order1 = 1 Then code1 = "<" Else code1 = ">"
        If order2 = 1 Then code2 = "<" Else code2 = ">"
        For i = 1 To UBound(arr) - 1
            For ii = i + 1 To UBound(arr)
                v1 = arr(ii, key1): v2 = arr(i, key1)
                If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"
                If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"
                tmp1 = Evaluate(v1 & code1 & v2)
                tmp0 = Evaluate(v1 & "=" & v2)
               
                v3 = arr(ii, key2): v4 = arr(i, key2)
                If TypeName(arr(ii, key2)) = "String" Then v3 = """" & arr(ii, key2) & """"
                If TypeName(arr(i, key2)) = "String" Then v4 = """" & arr(i, key2) & """"
                tmp2 = Evaluate(v3 & code2 & v4)
               
                If tmp1 = True Or (tmp0 = True And tmp2 = True) Then
                    For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next
                    For c = 1 To UBound(arr, 2)
                    arr(i, c) = arr(ii, c)
                    Next
                    For c = 1 To UBound(arr, 2)
                    arr(ii, c) = tmparr(c)
                    Next
                End If
            Next
        Next
    ElseIf key2 <> 0 And key3 <> 0 Then
    Rem 三个关键字排序
        If order1 = 1 Then code1 = "<" Else code1 = ">"
        If order2 = 1 Then code2 = "<" Else code2 = ">"
        If order3 = 1 Then code3 = "<" Else code3 = ">"
        For i = 1 To UBound(arr) - 1
            For ii = i + 1 To UBound(arr)
                v1 = arr(ii, key1): v2 = arr(i, key1)
                If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"
                If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"
                tmp1 = Evaluate(v1 & code1 & v2)
                tmp0 = Evaluate(v1 & "=" & v2)
               
                v3 = arr(ii, key2): v4 = arr(i, key2)
                If TypeName(arr(ii, key2)) = "String" Then v3 = """" & arr(ii, key2) & """"
                If TypeName(arr(i, key2)) = "String" Then v4 = """" & arr(i, key2) & """"
                tmp2 = Evaluate(v3 & "=" & v4)
                tmp3 = Evaluate(v3 & code2 & v4)
               
                v5 = arr(ii, key3): v6 = arr(i, key3)
                If TypeName(arr(ii, key3)) = "String" Then v5 = """" & arr(ii, key3) & """"
                If TypeName(arr(i, key3)) = "String" Then v6 = """" & arr(i, key3) & """"
                tmp4 = Evaluate(v5 & code2 & v6)
               
                If tmp1 = True Or (tmp0 = True And tmp3 = True) Or (tmp0 = True And tmp2 = True And tmp4 = True) Then
                    For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next
                    For c = 1 To UBound(arr, 2)
                    arr(i, c) = arr(ii, c)
                    Next
                    For c = 1 To UBound(arr, 2)
                    arr(ii, c) = tmparr(c)
                    Next
                End If
            Next
        Next
    End If
End If

sortarr = arr
End Function

doitbest

3、条件求和函数
相当于sumifs函数，但该函数在2007版本以上才有，且不能处理数组。此函数试用没有问题，但由于条件表达式多种多样，因此不敢保证在所有情况下，函数执行绝对无误。大家在应用中如发现问题，可在本贴中反馈。
Public Function sumifs(arr, c, ParamArray Other())
Rem 数组条件求和
Rem 参数1为待计算数组，参数2为被求和数组列号，参数3、4分别为比对条件列号和条件，参数5、6作用与参数3、4相同，从参数5、6开始可以设置多组条件，也可省略，类似sumifs工作表函数
Dim reg As Object, str, i, ii, n, num, he, s1, s2, s0
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"
he = 0
If LBound(arr) = 0 Then
Rem 一维数组
    For i = 0 To UBound(arr)
        If reg.test(Other(0)) = True Then
            s0 = reg.Execute(Other(0))(0).submatches(0)
            s1 = reg.Execute(Other(0))(0).submatches(1)
            s2 = reg.Execute(Other(0))(0).submatches(2)
            If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0) '求和条件中的百分比要转化为数值，系统方能识别
            If s0 = "" Then str = "=" & str
            If Evaluate(arr(i) & str) Then he = he + arr(i) '计算条件为数值
        Else
            If arr(i) Like Other(0) Then he = he + arr(i) '计算条件为字符串和通配符
        End If
    Next
Else
Rem 二维数组
    For i = 1 To UBound(arr)
        For ii = 1 To UBound(Other) Step 2
            If reg.test(Other(ii)) = True Then
                s0 = reg.Execute(Other(ii))(0).submatches(0)
                s1 = reg.Execute(Other(ii))(0).submatches(1)
                s2 = reg.Execute(Other(ii))(0).submatches(2)
                If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)
                If s0 = "" Then str = "=" & str
                If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""
            Else
                If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1
            End If
            
        Next
        If n = (UBound(Other) + 1) / 2 Then he = he + arr(i, c) '满足所有条件，则进行累加
        n = 0
    Next
End If
sumifs = he
End Function

doitbest

4、条件计数函数和条件求平均值函数
相当于countifs和averageifs函数，这两个函数与条件求和函数代码思路大同小异，不加细说。
Public Function countifs(arr, ParamArray Other())
Rem 数组条件计数函数
Rem 参数说明请参考sumifs函数
Dim reg As Object, str, i, ii, n, num, times, s1, s2, s0
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"
he = 0
times = 0
If LBound(arr) = 0 Then
Rem 一维数组
    For i = 0 To UBound(arr)
        If reg.test(Other(0)) = True Then
            s0 = reg.Execute(Other(0))(0).submatches(0)
            s1 = reg.Execute(Other(0))(0).submatches(1)
            s2 = reg.Execute(Other(0))(0).submatches(2)
            If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0)
            If s0 = "" Then str = "=" & str
            If Evaluate(arr(i) & str) Then times = times + 1
        Else
            If arr(i) Like Other(0) Then times = times + 1
        End If
    Next
Else
Rem 二维数组
    For i = 1 To UBound(arr)
        For ii = 1 To UBound(Other) Step 2
            If reg.test(Other(ii)) = True Then
                s0 = reg.Execute(Other(ii))(0).submatches(0)
                s1 = reg.Execute(Other(ii))(0).submatches(1)
                s2 = reg.Execute(Other(ii))(0).submatches(2)
                If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)
                If s0 = "" Then str = "=" & str
                If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""
            Else
                If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1
            End If
            
        Next
        If n = (UBound(Other) + 1) / 2 Then times = times + 1
        n = 0
    Next
End If
countifs = times
End Function

Public Function averageifs(arr, c, ParamArray Other())
Rem 数组条件求和
Rem 参数说明请参考sumifs函数
Dim reg As Object, str, i, ii, n, num, he, s1, s2, s0, times
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"
he = 0
If LBound(arr) = 0 Then
Rem 一维数组
    For i = 0 To UBound(arr)
        If reg.test(Other(0)) = True Then
            s0 = reg.Execute(Other(0))(0).submatches(0)
            s1 = reg.Execute(Other(0))(0).submatches(1)
            s2 = reg.Execute(Other(0))(0).submatches(2)
            If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0)
            If s0 = "" Then str = "=" & str
            If Evaluate(arr(i) & str) Then he = he + arr(i): times = times + 1
        Else
            If arr(i) Like Other(0) Then he = he + arr(i): times = times + 1
        End If
    Next
Else
Rem 二维数组
    For i = 1 To UBound(arr)
        For ii = 1 To UBound(Other) Step 2
            If reg.test(Other(ii)) = True Then
                s0 = reg.Execute(Other(ii))(0).submatches(0)
                s1 = reg.Execute(Other(ii))(0).submatches(1)
                s2 = reg.Execute(Other(ii))(0).submatches(2)
                If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)
                If s0 = "" Then str = "=" & str
                If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""
            Else
                If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1
            End If
            
        Next
        If n = (UBound(Other) + 1) / 2 Then he = he + arr(i, c): times = times + 1
        n = 0
    Next
End If
averageifs = he / times
End Function

doitbest

5、数组重排列函数
数组重排列函数在应用中比较普遍，存在多行多列数组与多行多列、一行多列、一列多行数组之间相互转换等多种变化，本函数基本能够以上各种可能。
Public Function trans(arr, Optional r = 0, Optional c = 0)
Rem 数组重排列函数
Rem 参数1为待排列数组，参数2为目标数组行数，参数3为目标数组列数。如对一维数组排列可只有一个参数，如对二维数组排列参数2、3只输入一个即可
Dim r1, c1, n, nn, brr(), tmp, count
If LBound(arr) = 0 Then
    If r > 0 Then c = Application.RoundUp((UBound(arr) + 1) / r, 0): GoTo 100
    If c > 0 Then r = Application.RoundUp((UBound(arr) + 1) / c, 0)
100:
    ReDim brr(1 To r, 1 To c)
    For c1 = 1 To c
       For r1 = 1 To r
            brr(r1, c1) = arr(n)
            n = n + 1
            If n > UBound(arr) Then Exit For
       Next
    Next
Else
    tmp = UBound(arr) * UBound(arr, 2)
    If r > 0 Then c = Application.RoundUp(tmp / r, 0): GoTo 200
    If c > 0 Then r = Application.RoundUp(tmp / c, 0)
200:
    ReDim brr(1 To r, 1 To c)
    nn = 1
    For c1 = 1 To c
       For r1 = 1 To r
            n = n + 1
            count = count + 1
            If count > tmp Then Exit For
            If n > UBound(arr) Then n = 1: nn = nn + 1
            brr(r1, c1) = arr(n, nn)
       Next
    Next
End If
trans = brr
End Function

doitbest

6、数组随机排列函数
Public Function sortarrbyrnd(arr)
Rem 数组随机排序函数
Dim r, c, i, ii, brr(), tmp1, tmp2, tmparr
Randomize
If LBound(arr) = 0 Then '一维数组随机排序
    ReDim brr(0 To UBound(arr))
    For i = 0 To UBound(brr) '将随机值写入辅助数组BRR，作为排序依据
        brr(i) = Rnd
    Next
    For i = 0 To UBound(brr) - 1
        For ii = i + 1 To UBound(brr)
            If brr(ii) < brr(i) Then
                tmp1 = brr(i): brr(i) = brr(ii): brr(ii) = tmp1
                tmp2 = arr(i): arr(i) = arr(ii): arr(ii) = tmp2
            End If
        Next
    Next
Else '二维数组随机排序
    ReDim brr(1 To UBound(arr))
    ReDim tmparr(1 To UBound(arr, 2))
    For i = 1 To UBound(brr)
        brr(i) = Rnd
    Next
    For i = 1 To UBound(brr) - 1
        For ii = i + 1 To UBound(brr)
            If brr(ii) < brr(i) Then
                tmp1 = brr(i): brr(i) = brr(ii): brr(ii) = tmp1
                For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next
                For c = 1 To UBound(arr, 2): arr(i, c) = arr(ii, c): Next
                For c = 1 To UBound(arr, 2): arr(ii, c) = tmparr(c): Next
            End If
        Next
     Next
End If
sortarrbyrnd = arr
End Function

doitbest

7、生成连续值判断数组函数
这里连续值定义为等比、等差序列，及其变异种类，函数结果生成一个包含连续序列起止位置的嵌套函数，方便下一步的个性化应用。
Public Function 连续值数组(arr, typenum, interval)
Rem 生成类如" array(array(a,b),array(c,d),array(e,f)) "结构的嵌套数组,例如a、b值分别为一个连续系列的起止位置
Rem 参数1为待判断数组，参数2（1为等差数列，2为等比数列），参数3为等差或等比数列的步长值
Dim brr(), i, a0, a1, flag, n, reg As Object, tmp0, tmp1, code, times
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "\d+"
If typenum = 1 Then code = "-" Else code = "/"
For i = 2 To UBound(arr)
    tmp0 = Val(reg.Execute(arr(i - 1, 1))(0))
    tmp1 = Val(reg.Execute(arr(i, 1))(0))
    If Evaluate(tmp1 & code & tmp0) = interval Then
        If flag = 0 Then a0 = i - 1: flag = 1
        a1 = i
        If i = UBound(arr) Then
            If flag = 1 Then
                times = times + 1
                ReDim Preserve brr(1 To times)
                brr(times) = Array(a0, a1)
            End If
        End If
    Else
        If flag = 1 Then
            times = times + 1
            ReDim Preserve brr(1 To times)
            brr(times) = Array(a0, a1)
        End If
        flag = 0
    End If
   
Next
连续值数组 = brr
End Function

doitbest

8、排名函数
如同许多工作表函数一样，RANK函数也不支持数组，更不可能实现中国式排名，给应用者带来遗憾和困扰。此函数可实现常规排名和中国式排名，在编写排名程序时可直接调用。
Public Function rank(num, arr, column0, type0)
Rem 排名函数
Rem 参数1为待排名值，参数2为数字列表数组，参数3为数组中的排序列列号，参数4（1为常规排名，2为中国式排名）
Dim i, n, str
If type0 = 1 Then
    For i = 1 To UBound(arr)
        If arr(i, column0) > num Then n = n + 1
    Next
ElseIf type0 = 2 Then
    For i = 1 To UBound(arr)
        If arr(i, column0) > num And InStr(vbCr & str & vbCr, vbCr & arr(i, column0) & vbCr) = 0 Then
            str = str & vbCr & arr(i, column0)
            n = n + 1
        End If
    Next
End If
rank = n + 1
End Function

doitbest

9、简单透视表函数
通过透视处理，形成类似简单报表的数组，能够满足很多工作中的基本需求。SQL语句中有类似的转置功能，但用起来更麻烦，不如这个实用。
Public Function PivotTable(arr, rowfields, columnfields, datafields)
Rem 数组透视，将数组生成简单报表
Rem 参数1为待处理数组，参数2为报表行标题的数组列号，参数3为报表列标题的数组列号，参数4为报表数值区域的数组列号
Dim d1, d2, d3, brr(), str, k1, k2, i, ii
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
    d1(arr(i, rowfields)) = "" '生成行标题字典
    d2(arr(i, columnfields)) = "" '生成列标题字典
    str = arr(i, rowfields) & vbCr & arr(i, columnfields)
    d3(str) = d3(str) + arr(i, datafields)
Next
ReDim brr(1 To d1.count + 1, 1 To d2.count + 1)
k1 = d1.keys
k2 = d2.keys
For i = 2 To UBound(brr) '生成行标题
    brr(i, 1) = k1(i - 2)
Next
For i = 2 To UBound(brr, 2) '生成列标题
    brr(1, i) = k2(i - 2)
Next
For i = 2 To UBound(brr) '生成报表数值区域
    For ii = 2 To UBound(brr, 2)
        str = brr(i, 1) & vbCr & brr(1, ii)
        brr(i, ii) = d3(str)
    Next
Next
Set d1 = Nothing
Set d2 = Nothing
Set d3 = Nothing
PivotTable = brr
End Function