设为首页收藏本站|繁體中文

Excel 技巧网

 找回密码
 注册

QQ登录

只需一步,快速开始

手机号码,快捷登录

查看: 30267|回复: 22

[Excel VBA] 利用VBA的Transpose进行数组转置的一些小发现及其应用

[复制链接]
发表于 2011-6-2 13:23:03 | 显示全部楼层 |阅读模式
  • 署名作者: amulee
  • 版权声明: 版权归本站与作者共有 除本站官方外非作者本人转载须经许可并注明出处
  • 本文来自:
  • 引用作品:
  • 适用版本: 2010 2007 2003以前版本 
  • 语言环境: 简体中文
  • 学习方法: 掌握Excel技巧的关键是动手操作 | 下载 ≠ 知识


  • 免费注册成为本站会员,享用更多功能,结识更多Office办公高手!

    您需要 登录 才可以下载或查看,没有帐号?注册

    x
    本帖最后由 amulee 于 2011-6-2 14:41 编辑

    Transpose原为工作表函数,可以对数组进行转置。
    在VBA中,Transpose常常用于多表统计的动态数组进行转置从而得到最终结果。
    Transpose的使用会产生以下有趣的效果:
    1、会将Arr()()形式的数组自动转变成二维数组。如果经常接触数组的话,这个形式应该不会陌生。例如下面的代码就可以生成这个形式
    1. Dim arr(1 To 5), arr1
    2. Dim arrtemp
    3. For i = 1 To 5
    4.     ReDim arrtemp(1 To 4)
    5.     For j = 1 To 4
    6.         arrtemp(j) = Cells(i, j).Address
    7.     Next j
    8.     arr(i) = arrtemp
    9. Next i
    复制代码
    这个数组的最外层是一个5个元素的一维数组,每个元素又是一个数组。arr(1)就表示最外层数组的一个元素,而这个arr(1)本身又是一个数组,它其中的元素可以用arr(N)的形式表示,因而其中一个元素的数组可以为arr(1)(1)。

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    这个数组利用Transpose进行转置之后,可以发现结果竟然变成了一个二维数组:
    1. Sub 程序1()
    2.     Dim arr(1 To 5), arr1
    3.     Dim arrtemp
    4.     For i = 1 To 5
    5.         ReDim arrtemp(1 To 4)
    6.         For j = 1 To 4
    7.             arrtemp(j) = Cells(i, j).Address
    8.         Next j
    9.         arr(i) = arrtemp
    10.     Next i
    11.     arr1 = WorksheetFunction.Transpose(arr)
    12.     Stop
    13. End Sub
    复制代码

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    这个转换过程中,只要保证内层数组的每个元素个数都一致,即可实现转换。参见下面两段程序:
    1. '成功转置
    2. Sub 程序4()
    3.     Dim arr(1 To 5), arr1
    4.     Dim arrtemp
    5.     For i = 1 To 4
    6.         ReDim arrtemp(1 To 4)
    7.         For j = 1 To 4
    8.             arrtemp(j) = Cells(i, j).Address
    9.         Next j
    10.         arr(i) = arrtemp
    11.     Next i
    12.     arrtemp = Array(1, 2, 3, 4)
    13.     arr(5) = arrtemp
    14.     arr1 = WorksheetFunction.Transpose(arr)
    15.     Stop
    16. End Sub
    17. '不成功转置
    18. Sub 程序5()
    19.     Dim arr(1 To 5), arr1
    20.     Dim arrtemp
    21.     For i = 1 To 4
    22.         ReDim arrtemp(1 To 4)
    23.         For j = 1 To 4
    24.             arrtemp(j) = Cells(i, j).Address
    25.         Next j
    26.         arr(i) = arrtemp
    27.     Next i
    28.     arrtemp = Array(1, 2, 3)
    29.     arr(5) = arrtemp
    30.     arr1 = WorksheetFunction.Transpose(arr)
    31.     Stop
    32. End Sub
    复制代码
    同时,还要满足两个数组都为一维数组,否则转置失败:
    1. '转置失败
    2. Sub 程序6()
    3.     Dim arr(1 To 5, 1 To 1), arr1
    4.     Dim arrtemp
    5.     For i = 1 To 5
    6.         ReDim arrtemp(1 To 4)
    7.         For j = 1 To 4
    8.             arrtemp(j) = Cells(i, j).Address
    9.         Next j
    10.         arr(i, 1) = arrtemp
    11.     Next i
    12.     arr1 = WorksheetFunction.Transpose(arr)
    13.     Stop
    14. End Sub
    15. '转置失败
    16. Sub 程序7()
    17.     Dim arr(1 To 5), arr1
    18.     Dim arrtemp
    19.     For i = 1 To 5
    20.         ReDim arrtemp(1 To 4, 1 To 1)
    21.         For j = 1 To 4
    22.             arrtemp(j, 1) = Cells(i, j).Address
    23.         Next j
    24.         arr(i) = arrtemp
    25.     Next i
    26.     arr1 = WorksheetFunction.Transpose(arr)
    27.     Stop
    28. End Sub
    复制代码


    此外,三层以上的也会失败:
    1. '转置失败
    2. Sub 程序0()
    3.     Dim arr2(0 To 0)
    4.     Dim arr(1 To 5), arr1
    5.     Dim arrtemp
    6.     For i = 1 To 5
    7.         ReDim arrtemp(1 To 4, 1 To 1)
    8.         For j = 1 To 4
    9.             arrtemp(j, 1) = Cells(i, j).Address
    10.         Next j
    11.         arr(i) = arrtemp
    12.     Next i
    13.     arr2(0) = arr
    14.     arr1 = WorksheetFunction.Transpose(arr2)
    15.     Stop
    16. End Sub
    复制代码


    结论1:当转置Arr(N)(M)形式的数组时,只要两个数组维度都是一维的,且内层数组元素个数相同(不管上下限如何标示),可以返回一个二维数组,其尺寸为M*N,即第一维是M,第二维是N


    2、其实这个结论在结论1就可以发现。我们将Arr和ArrTemp稍作改变,程序如下:
    1. Sub 程序2()
    2.     Dim arr(2 To 5), arr1
    3.     Dim arrtemp
    4.     For i = 2 To 5
    5.         ReDim arrtemp(2 To 4)
    6.         For j = 2 To 4
    7.             arrtemp(j) = Cells(i, j).Address
    8.         Next j
    9.         arr(i) = arrtemp
    10.     Next i
    11.     arr1 = WorksheetFunction.Transpose(arr)
    12.     Stop
    13. End Sub
    复制代码

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    可以发现结果的二维数组其二维都是以1为下限的数组,其上限根据数组实际值确定。这个现象其实是Transpose的一个特性,会强制将数组转换为1为下限的数组。
    参见以下程序:
    1. Sub 程序3()
    2.     Dim arr(2 To 5, -1 To 9), arr1
    3.     arr1 = WorksheetFunction.Transpose(arr)
    4.     Stop
    5. End Sub
    复制代码

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用


    结论2:Transpose会强制将数组转换成下限为1的数组。


    3、再将数组改变一下,将其中一个变量设为对象
    1. '强制的类型转换
    2. Sub 程序9()
    3.     Dim arr(1 To 5), arr1
    4.     Dim arrtemp
    5.     Dim Ft As New StdFont
    6.     For i = 1 To 5
    7.         ReDim arrtemp(1 To 4)
    8.         arrtemp(1) = Cells(i, 1).Address
    9.         arrtemp(2) = CStr(i)
    10.         arrtemp(3) = i * 100 + j
    11.         Set arrtemp(4) = Ft
    12.         arr(i) = arrtemp
    13.     Next i
    14.     arr1 = WorksheetFunction.Transpose(arr)
    15.     Stop
    16. End Sub
    复制代码
    可以看到,这个arrtemp中有一个对象变量,在进行Transpose转置后,进行了强制的类型转换,转换后仅保存该对象变量的默认属性。

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用


    原因在于Transpose返回结果不能是带有任何类型的数组,只能是Variant数组,而且转换结果不为对象,所以在转换过程中会将对象变量进行强制转换,转换值即为对象的默认属性。可以看到,下列程序不能用指定类型的arr1作为Transpose。
    1. '强制的类型转换,出错
    2. Sub 程序10()
    3.     Dim arr(1 To 5) As StdFont
    4.     Dim arr1() As StdFont
    5.     For i = 1 To 5
    6.         Set arr(i) = New StdFont
    7.     Next i
    8.     arr1 = WorksheetFunction.Transpose(arr)
    9.     Stop
    10. End Sub
    11. Sub 程序11()
    12.     Dim arr(1 To 5) As Long
    13.     Dim arr1() As Long
    14.     arr1 = WorksheetFunction.Transpose(arr)
    15.     Stop
    16. End Sub
    复制代码
    下列程序演示了对象的强制转换
    1. '强制的类型转换
    2. Sub 程序12()
    3.     Dim arr(1 To 5) As StdFont
    4.     Dim arr1() As Variant
    5.     For i = 1 To 5
    6.         Set arr(i) = New StdFont
    7.     Next i
    8.     arr1 = WorksheetFunction.Transpose(arr)
    9.     Stop
    10. End Sub
    复制代码

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用



    结论3:当进行Transpose转置时,只能用Variant数组进行接收返回值的变量。

    结论4:当进行Transpose转置的数组中含有对象,转置后该对象的自动转换为其默认属性。


    Transpose使用.rar (18.3 KB, 下载次数: 117)

    评分

    参与人数 2魅力值 +10 收起 理由
    chenlifeng + 5 太强悍了!
    zzmxy + 5 厉害

    查看全部评分

     楼主| 发表于 2011-6-2 13:44:54 | 显示全部楼层
    本帖最后由 amulee 于 2011-6-2 14:10 编辑

    这里针对结论1做一下讨论,也就是VBA编程中最常用的汇总。
    本例是一个最常用的汇总,原帖 http://www.exceltip.net/thread-21903-1-1.html

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用


    此处,我多加了一个汇总,以说明问题。

    常用的做法可能是利用一个动态数组再加上字典来联合完成,用字典记录记录所在行号,通过不断地Redim Preserve来扩大数组的上限。代码如下:
    1. Sub 统计_字典和数组联合法()
    2.     Dim ArrYS, d, ArrJG()
    3.     Dim i&, k&, RowN&, t#
    4.     Application.ScreenUpdating = False
    5.     '原始数组
    6.     ArrYS = Range("M2:P" & Range("M65536").End(xlUp).Row)
    7.     '定义字典
    8.     Set d = CreateObject("Scripting.Dictionary")
    9.     '定义结果数组
    10.     ReDim ArrJG(1 To 4, 1 To 1)
    11.     '遍历原始数组
    12.     For i = 1 To UBound(ArrYS)
    13.         If Not d.exists(ArrYS(i, 1)) Then
    14.             '计数增加1,数组增加
    15.             k = k + 1
    16.             ReDim Preserve ArrJG(1 To 4, 1 To k)
    17.             d(ArrYS(i, 1)) = k
    18.             ArrJG(1, k) = ArrYS(i, 1)
    19.             ArrJG(2, k) = ArrYS(i, 2)
    20.         End If
    21.         '获取记录所在行
    22.         RowN = d(ArrYS(i, 1))
    23.         '汇总
    24.         ArrJG(3, RowN) = ArrJG(3, RowN) + 1
    25.         ArrJG(4, RowN) = ArrJG(4, RowN) + ArrYS(i, 4)
    26.     Next i
    27.     With Sheet2
    28.         .Cells.Clear
    29.         .Range("A2").Resize(d.Count, 4) = WorksheetFunction.Transpose(ArrJG)
    30.         .Range("A1") = "单位代码"
    31.         .Range("B1") = "单位名称"
    32.         .Range("C1") = "人数"
    33.         .Range("D1") = "补助汇总"
    34.         .Activate
    35.     End With
    36.     Application.ScreenUpdating = True
    37. End Sub
    复制代码


    利用结论1,可以直接将结果数组赋值在字典中
    1. Sub 统计_字典法()
    2.     Dim ArrYS, d, ArrJG(), arrTemp
    3.     Dim i&
    4.     Application.ScreenUpdating = False
    5.     ArrYS = Range("M2:P" & Range("M65536").End(xlUp).Row)
    6.     Set d = CreateObject("Scripting.Dictionary")
    7.     For i = 1 To UBound(ArrYS)
    8.         '直接将结果数组添加入字典
    9.         If Not d.exists(ArrYS(i, 1)) Then
    10.             ReDim arrTemp(1 To 3)
    11.             arrTemp(1) = ArrYS(i, 2)
    12.         Else
    13.             arrTemp = d(ArrYS(i, 1))
    14.         End If
    15.         arrTemp(2) = arrTemp(2) + 1
    16.         arrTemp(3) = arrTemp(3) + ArrYS(i, 4)
    17.         d(ArrYS(i, 1)) = arrTemp
    18.     Next i
    19.     With Sheet2
    20.         .Cells.Clear
    21.         .Range("A2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    22.         '利用结论1进行转置
    23.         .Range("B2").Resize(d.Count, 3) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.items))
    24.         .Range("A1") = "单位代码"
    25.         .Range("B1") = "单位名称"
    26.         .Range("C1") = "人数"
    27.         .Range("D1") = "补助汇总"
    28.         .Activate
    29.     End With
    30.     Application.ScreenUpdating = True
    31. End Sub
    复制代码


    两者运行速度差不多。第二种方法比较直观,直接将结果数组存储在字典中,也不会搞错维度。

    Transpose应用之汇总.rar (53.03 KB, 下载次数: 61)
    回复 支持 反对

    使用道具 举报

     楼主| 发表于 2011-6-2 14:14:40 | 显示全部楼层
    本帖最后由 amulee 于 2011-6-2 14:19 编辑

    应用2、强制数组下限从1开始
    Split函数返回的数组始终是从0开始,哪怕加了Option。
    对于初学者来说或者搞不清楚哪个数组是0开始,哪个数组是1开始的。用Transpose即可实现始终是1开始。
    1. Option Base 1
    2. '对于搞不清楚哪个数组是0开始,哪个数组是1开始的。用Transpose即可实现始终是1开始。
    3. Sub Test()
    4.     Dim strA$, arr, arr1
    5.     strA = "1,2,3,4,5,6"
    6.     arr = Split(strA, ",")
    7.     arr1 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Split(strA, ",")))
    8.     Stop
    9. End Sub
    复制代码

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用
    回复 支持 反对

    使用道具 举报

     楼主| 发表于 2011-6-2 14:23:26 | 显示全部楼层
    本帖最后由 amulee 于 2011-6-3 08:55 编辑

    结论4应用:批量输入
    这样的输入界面是不是很常用啊

    利用VBA的Transpose进行数组转置的一些小发现及其应用

    利用VBA的Transpose进行数组转置的一些小发现及其应用


    当点击”确定“按钮后一般大都会利用循环进行输入。知道结论4之后可以免去循环,只需要定义一个对象数组,这个数组依次对应工作表中的相应字段即可。
    我们可以在窗体初始化的时候对象数组赋值。确认输入的代码将会变得非常简单。
    1. Dim ArrTxt()
    2. '窗体初始化时候,绑定TextBox控件到数组
    3. Private Sub UserForm_Initialize()
    4.     Dim i%
    5.     ReDim ArrTxt(1 To 3)
    6.     For i = 1 To 3
    7.         Set ArrTxt(i) = Me.Controls("Textbox" & i)
    8.     Next
    9. End Sub
    10. '确定输入代码
    11. Private Sub CommandButton1_Click()
    12.     Dim arr
    13.     arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ArrTxt))
    14.     Sheet3.Range("A" & Sheet3.Cells.Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = arr
    15. End Sub
    复制代码
    Transpose应用之输入.rar (13.22 KB, 下载次数: 64)
    回复 支持 反对

    使用道具 举报

    发表于 2011-6-2 21:59:29 | 显示全部楼层
    回复 支持 反对

    使用道具 举报

    发表于 2011-6-3 00:14:11 | 显示全部楼层
    很不错
    回复 支持 反对

    使用道具 举报

     楼主| 发表于 2011-6-3 08:49:09 | 显示全部楼层
    本帖最后由 amulee 于 2011-6-3 09:26 编辑

    经查发现,原来Excel的智能性真的很强。
    4楼那个示例,不需要Transpose也可进行强制转换。按钮只需要以下代码即可:
    1. Private Sub CommandButton1_Click()
    2.     Dim arr
    3.     arr = ArrTxt
    4.     Sheet3.Range("A" & Sheet3.Cells.Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = arr
    5. End Sub
    复制代码
    但是利用这个代码操作,所有输入的值都将存储为文本,数字变为文本数字。
    而经过Transpose转换之后,文本数字将自动转换为数字。

    因而结论4还应加点内容,除了强制的类型转换外,对于文本类型默认属性的对象,会根据实际情况自动转换为数字或者文本。
    回复 支持 反对

    使用道具 举报

    发表于 2011-6-12 17:58:24 | 显示全部楼层
    厉害,精华啊~~~

    Transpose()的时候,如果数组里某个元素的文本长度超过256个时,就会Error,不知道怎么解决~~~
    我最头痛的也是这个问题

    回复 支持 反对

    使用道具 举报

    发表于 2011-6-15 09:28:38 | 显示全部楼层
    双transpose对格式的影响,以前没接触VBA,记得DJ和K哥讨论过.

    好文章,学习了.
    回复 支持 反对

    使用道具 举报

    发表于 2011-6-29 07:28:39 | 显示全部楼层
    阿木的VBA造诣实在是高啊。
    回复 支持 反对

    使用道具 举报

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

    本版积分规则

    关闭

    站长推荐上一条 /1 下一条

    Excel技巧网的会员探讨问题仅代表其个人意见,与网站的立场无关。任何违反国家和地方相关法律法规的言论,本站有义务协助政府相关部门追究发言者的责任!
    本站中非注明转载文章与案例的版权为作者与Excel技巧网共有。若非原文作者,本站之外任何单位或个人未经允许,不得将其用于商业用途。
    若非原文作者,任何形式的非商业性转载必须获得Excel技巧网或作者允许,并注明作者和出处。
    会员发表的帖子如涉及版权纠纷,须自行负责。详情请参考注册时的网站服务条款。
    本站特聘法律顾问:沈学律师

    Archiver|手机版|Excel技巧网 ( 闽ICP备08107682号-2 ) | 闽公网安备 35020302032608号  

    GMT+8, 2018-12-17 18:37

    Powered by Discuz! X3.4

    © 2001-2017 Comsenz Inc.

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