ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E文精选 > Excel VBA > 利用VBA的Transpose进行数组转置的一些小发现及其应用

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

作者：绿色风 分类： 时间：2022-08-17 浏览：435
楼主
amulee		 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)。

 
这个数组利用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

 
这个转换过程中，只要保证内层数组的每个元素个数都一致，即可实现转换。参见下面两段程序：
  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

 
可以发现结果的二维数组其二维都是以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

 

结论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转置后，进行了强制的类型转换，转换后仅保存该对象变量的默认属性。

 

原因在于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

 


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

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



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


 

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

常用的做法可能是利用一个动态数组再加上字典来联合完成，用字典记录记录所在行号，通过不断地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
3楼
amulee		 应用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


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

 

当点击”确定“按钮后一般大都会利用循环进行输入。知道结论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
5楼
wqfzqgk
6楼
wise		 很不错
7楼
amulee		 经查发现，原来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还应加点内容，除了强制的类型转换外，对于文本类型默认属性的对象，会根据实际情况自动转换为数字或者文本。
8楼
zzmxy		 厉害，精华啊~~~

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


9楼
liuguansky		 双transpose对格式的影响,以前没接触VBA,记得DJ和K哥讨论过.


好文章,学习了.
10楼
水星钓鱼		 阿木的VBA造诣实在是高啊。
11楼
轩辕轼轲		 顶你  阿木
12楼
angel928		 分享学习
13楼
じ☆潴の︵ゞ
14楼
lilytracy		 謝謝分享
支持一下

15楼
5fh		 2楼的结果为什么不用sql语句实现？一个 group by 单位代码, 单位名称 就搞定了
16楼
libryant		 总结的挺好的帖子，谢谢LZ

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap