自定义数组转置函数

microyip · 发表于 2018-12-24 11:02

本帖最后由 microyip 于 2018-12-25 08:30 编辑

很经常发生使用系统数组转置函数Application.WorksheetFunction.Transpose时出错的情况，目前个人碰到的原因无非就是两种：1、数组元素超过65536和某元素长度超过255字符
2、SQL读取得到的数据里存在Null数值或者读取表里的数值存在错误值
为此，个人就建立了一个自定义转置函数，以便转换。又加上最近有朋友在论坛里咨询转置出错的解决方案，特此分享。如有不当之处，敬请高手指正。2018.12.25，更新代码，增加了转置结果形式

Function TranVariant(ByVal vData As Variant, Optional ByVal bNoDimension2 As Boolean = False) As Variant
'对二维以下进行转置数组
'参数说明：
' bNoDimension，vData(2 To 3, 4 To 4)转置后是否转为vData(1 To 2)形式或vData(2 To 2, 3 To 4)转置后是否转为vData(1 To 2)形式
'返回值说明：
' 错误信息：数组维数大于2
' 原vData值：非数组
' 数组：已经按要求转置的数组
Dim nDimension As Integer '维度
Dim vNewData As Variant, nRow As Double, nCol As Double
nDimension = -1
If IsArray(vData) Then
On Error Resume Next
Do While Err.Number = 0
nDimension = nDimension + 1
If nDimension = 0 Then
vNewData = vData(LBound(vData)) '检查是否vData(1)形式数组
If Err.Number = 0 Then Exit Do
Else
vNewData = UBound(vData, nDimension + 1)
End If
Loop
Err.Clear
On Error GoTo 0
If nDimension > 2 Then
vNewData = "数组维数大于2！"
ElseIf nDimension = 0 Then
ReDim vNewData(1 To 1, 1 To UBound(vData) - LBound(vData) + 1)
For nCol = 1 To UBound(vNewData, 2)
If Not IsNull(vData(nCol + LBound(vData) - 1)) Then _
vNewData(1, nCol) = vData(nCol + LBound(vData) - 1)
Next
ElseIf bNoDimension2 And (UBound(vData) = LBound(vData) Or UBound(vData, 2) = LBound(vData, 2)) Then
If UBound(vData) = LBound(vData) Then
ReDim vNewData(1 To UBound(vData, 2) - LBound(vData, 2) + 1)
For nCol = 1 To UBound(vNewData)
If Not IsNull(vData(LBound(vData), nCol + LBound(vData, 2) - 1)) Then _
vNewData(nCol) = vData(LBound(vData), nCol + LBound(vData, 2) - 1)
Next
Else
ReDim vNewData(1 To UBound(vData) - LBound(vData) + 1)
For nRow = 1 To UBound(vNewData)
If Not IsNull(vData(nRow + LBound(vData) - 1, LBound(vData, 2))) Then _
vNewData(nRow) = vData(nRow + LBound(vData) - 1, LBound(vData, 2))
Next
End If
Else
ReDim vNewData(1 To UBound(vData, 2) - LBound(vData, 2) + 1, 1 To UBound(vData) - LBound(vData) + 1)
For nRow = 1 To UBound(vNewData)
For nCol = 1 To UBound(vNewData, 2)
If Not IsNull(vData(nCol + LBound(vData) - 1, nRow + LBound(vData, 2) - 1)) Then _
vNewData(nRow, nCol) = vData(nCol + LBound(vData) - 1, nRow + LBound(vData, 2) - 1)
Next
Next
End If
vData = vNewData
End If
TranVariant = vData
End Function

复制代码

zopey · 发表于 2018-12-24 11:08

可以继续研究数组排序函数。

microyip · 发表于 2018-12-24 12:13

zopey 发表于 2018-12-24 11:08
可以继续研究数组排序函数。

有需要数组排序的，请参阅http://club.excelhome.net/thread-1443182-1-1.html

aman1516 · 发表于 2018-12-24 12:42

本帖最后由 aman1516 于 2018-12-24 12:52 编辑

谢谢分享，更方便应用
老师能否结合 System.Collections.Sortedlist 自动排序的特性，加上递归，做个任意多Key的数组排序，
之前想写一个，但一直不知对应多Key时，如何递归处理其它各列数据，困扰多日......

microyip · 发表于 2018-12-24 13:08

aman1516 发表于 2018-12-24 12:42
谢谢分享，更方便应用
老师能否结合 System.Collections.Sortedlist 自动排序的特性，加上递归，做个任意 ...

任意多个Key就没做过，但任意Key就有，请参考3楼的链接

zhangcheng6688 · 发表于 2018-12-26 07:35

谢谢分享。。。

kimmyyang · 发表于 2019-5-29 09:51

数组转置不错不错

双夕 · 发表于 2020-11-10 12:05

Application.WorksheetFunction.Transpose为什么这个函数在xlsm表格中运行失败，而在xlsx中可以正常运行

microyip · 发表于 2020-11-10 13:16

双夕发表于 2020-11-10 12:05
Application.WorksheetFunction.Transpose为什么这个函数在xlsm表格中运行失败，而在xlsx中可以正常运行

估计是你的xlsm有引用失败的引用

		自动登录	找回密码
密码			免费注册

[分享] 自定义数组转置函数

评分