ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 29408|回复: 63

[原创] 共享一组实用的自定义函数

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2016-1-9 11:52 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖已被收录到知识树中,索引项:自定义函数开发
程序语言中的函数和数学中的函数基本概念是相似的。程序语言中的函数也有参数和返回值,以及定义和调用。程序中的函数,就是将一些程序语句结合在一起的部件,通过多次调用,函数可以不止一次地在程序中运行。
程序中使用函数的好处:
一是将大问题分解成许多小问题。函数可以将程序分成多个子程序段,开发者可以独立编写各个子程序,实现程序开发流程的分解。每个函数实现特定功能,我们可以针对这个函数来编写程序。计算机程序中,函数的实现千变万化。函数调用中,即使函数的实现改变了,只要函数的调用方式不变,调用它的程序就不用做任何改变。这种函数调用的结构,使得主程序精巧明了,使程序修改更加容易,程序结构变得具有一种排列紧凑、疏密得当的美感。
二是便于检测错误。一个函数写好后,我们会检测其实现的正确性。程序由多个函数组成的,我们确定每一个函数是正确后,总程序出错的可能性就会降低。另外函数的代码量小,也便于检测错误。
三是实现封装和重用。“封装”的意思是隐藏细节,应用时只需要传递相应的参数给函数,函数就会返回相应的结果,而不必关注函数操作的具体实现。“重用”的特点体现在,各个程序都可以直接调用已经写好的函数,而不用重复编写代码,这种重用提高了程序开发效率。
四是便于维护。每个函数都必须要有清楚的界面和注释,包含了功能,输入的参数、返回值的解释等。让人知道如何调用这个函数。
实际上,系统提供的函数与用户自定义函数本质上是一样的,只是前者显得更专业,速度可能快一些罢了。
对于EXCELVBA来说,代码往往是短小精悍的,自定义函数就非必须。但中等以上的代码量也很常见,自定义函数就能够体现出其价值。而且,从成为一个资深代码开发者的标准来看,自定义函数的知识储备与应用习惯的培养,也是必须的。
以下和大家分享一组自认为实用价值较高的自定义函数,当然函数代码仍有进一步优化的余地,这里只是抛砖引玉,开启思路,谨供参考。函数中的说明语句如果不够明确,可结合示例文件加深理解。

一组自定义函数.rar

56.72 KB, 下载次数: 2145

评分

8

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 11:54 | 显示全部楼层
本帖最后由 doitbest 于 2016-1-9 11:58 编辑

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 11:56 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 11:59 | 显示全部楼层
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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:01 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:02 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:09 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:10 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:11 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-1-9 12:12 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
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
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 21:06 , Processed in 0.052312 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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