VB/VBA数组Transpose转置DLL，32位/64位均可用

jz_l

wodewan 发表于 2023-7-10 11:31
，本来也想搞个类似的，无奈初学，看的出来大佬对C/C++和VB的数据转换，内存结构很精通啊，有没啥学习 ...

熟悉点SAFEARRAY安全数组结构就行了，知道了数组描述结构位置、数据位置，其它的都好操作了

jz_l

230716更新，修复了1个Bug，增加了使用示例。

leolee82

原地转置，用临时变量变换数据位置，再调整SAFEARRAY中的SAFEARRAYBOUND，应该是这样操作吧？速度会慢点，省内存

386026398

jz_l 发表于 2023-7-9 15:37
DLL及使用示例。。
230716更新，修复了1个Bug。

怎么转为64位的呢，且附件也没有引用dll。能告诉一下怎么使用吗

gjj136138139

在vba中经常会用到动态数组redim preserve，一般都是二维的，归集好数据后，要把二维动态数组转置，excel内置的转置功能，在vba里用application.transpose时会有很多bug,比方说行数，列数的限制等，所以我自己用vba写了一个简单的转置函数来替代application.transpose.Function Transpose2(Arr) '自制转置函数，系统函数有缺陷,将二维数组行列转置
    Dim Brr, L1, U1, L2, U2, i&, j&
    L1 = LBound(Arr, 1): U1 = UBound(Arr, 1)
    L2 = LBound(Arr, 2): U2 = UBound(Arr, 2)
    ReDim Brr(L2 To U2, L1 To U1)
    For i = L1 To U1
        For j = L2 To U2
            Brr(j, i) = IIf(IsNull(Arr(i, j)), 0, Arr(i, j))
        Next
    Next
    Transpose2 = Brr
End Function

gjj136138139

Function Transpose2(Arr)
    Dim Brr, L1, U1, L2, U2, i&, j&
    L1 = LBound(Arr, 1): U1 = UBound(Arr, 1)
    L2 = LBound(Arr, 2): U2 = UBound(Arr, 2)
    ReDim Brr(L2 To U2, L1 To U1)
    For i = L1 To U1
        For j = L2 To U2
            Brr(j, i) = IIf(IsNull(Arr(i, j)), 0, Arr(i, j))
        Next
    Next
    Transpose2 = Brr
End Function
在vba里经常会用到动态数组来归集相应数据，一般是二维数组，归集完后，一般要转置来展示数据等，内置的转置功能，在vba中用application.transpose来处理时，会有很多bug，比方说行数，列数的限制，以致数据展示不全（错误），所以自己写了一个转置功能的函数。简单易用，好理解。

jz_l

leolee82 发表于 2023-7-16 21:06
原地转置，用临时变量变换数据位置，再调整SAFEARRAY中的SAFEARRAYBOUND，应该是这样操作吧？速度会慢点， ...

基本上是这样
有时候可用内存不够了，只能原地转置，会慢不少

jz_l

386026398 发表于 2023-7-17 07:47
怎么转为64位的呢，且附件也没有引用dll。能告诉一下怎么使用吗

打开附件的工作簿文件，Alt+F11打开VBA编辑器，查看示例源代码。
使用：
1、复制API声明部分

1. #If Win64 Then 'Win64 + VBA7
   
2.     Private Declare PtrSafe Function ArrayPtrV Lib "vbaEx64.dll" (ByRef vAry As Variant) As LongPtr
   
3.     Private Declare PtrSafe Function Transpose Lib "vbaEx64.dll" (ByRef ary() As Any) As Boolean
   
4.     Private Declare PtrSafe Function TransposePtr Lib "vbaEx64.dll" Alias "Transpose" _
   
5.                         (ByVal pAry As LongPtr) As Boolean
   
6. #Else 'Win32 + VBA7 Or Win32 + VBA6
   
7.     Private Declare Function ArrayPtrV Lib "vbaEx32.dll" (ByRef vAry As Variant) As Long
   
8.     Private Declare Function Transpose Lib "vbaEx32.dll" (ByRef ary() As Any) As Boolean
   
9.     Private Declare Function TransposePtr Lib "vbaEx32.dll" Alias "Transpose" _
   
10.                         (ByVal pAry As Long) As Boolean
    
11. #End If

复制代码

2、设置原数组的值，如：

1. 
   
2. Dim ary() As Long, l as Long
   
3. 
   
4. ReDim ary(1 To 3, 2 To 10)
   
5. For c = 2 To 10
   
6.     For r = 1 To 3
   
7.         l = l + 1
   
8.         ary(r, c) = l
   
9.     Next
   
10. Next

复制代码

3、调用转置API

1. 
   
2. If Transpose(ary()) Then '转置成功
   
3.     'Do Something
   
4. End If

复制代码

对于String数组、包含数组的Variant，调用方式参见附件示例。

若提示DLL文件未找到，可
1、在调用API前，调用（将对应源码复制到你的工作簿源码中）：

1. Call SetCurDir

复制代码

２、或者使用DLL绝对路径，如DLL在【D:\ABC\】文件夹中，API声明如下：

1. 
   
2. #If Win64 Then 'Win64 + VBA7
   
3.     Private Declare PtrSafe Function ArrayPtrV Lib "D:\ABC\vbaEx64.dll" (ByRef vAry As Variant) As LongPtr
   
4.     Private Declare PtrSafe Function Transpose Lib "D:\ABC\vbaEx64.dll" (ByRef ary() As Any) As Boolean
   
5.     Private Declare PtrSafe Function TransposePtr Lib "vbaEx64.dll" Alias "Transpose" _
   
6.                         (ByVal pAry As LongPtr) As Boolean
   
7. #Else 'Win32 + VBA7 Or Win32 + VBA6
   
8.     Private Declare Function ArrayPtrV Lib "D:\ABC\vbaEx32.dll" (ByRef vAry As Variant) As Long
   
9.     Private Declare Function Transpose Lib "D:\ABC\vbaEx32.dll" (ByRef ary() As Any) As Boolean
   
10.     Private Declare Function TransposePtr Lib "vbaEx32.dll" Alias "Transpose" _
    
11.                         (ByVal pAry As Long) As Boolean
    
12. #End If

复制代码

jz_l

gjj136138139 发表于 2023-7-17 13:48
Function Transpose2(Arr)
    Dim Brr, L1, U1, L2, U2, i&, j&
    L1 = LBound(Arr, 1): U1 = UBound ...

对于简单的类型如Long、Single、Currency、Date等来说，统一的一个自定义函数除了损失点效率，也没啥可说的
对于包装类型Variant来说，数组元素里如果还包含数组、对象，自定义函数处理起来要复杂些，而Application.Transpose已经处理不了了
用于用户定义类型(UDT)来说，自定义函数需要对每种UDT专门1对1处理，Application.Transpose则不支持