XL 2021 Vos avis SVP: Une fonction TRANSPOSE() à améliorer

Sub testarray()
    tbl = Array(1, 2, 3, 4, 5)
     texte = "Avant" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : 0" & vbCrLf
     
  tbl = TransposeX(tbl)
    MsgBox tbl(0, 1)
      MsgBox texte & "Apres" & vbCrLf & "ligne : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2)
End Sub

Sub test2D()
    Dim tbl(1 To 5, 1 To 10), tbl2
    texte = "Avant" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2) & vbCrLf
    tbl2 = TransposeX(tbl)
    MsgBox texte & "Apres" & vbCrLf & "Dim 1 : " & UBound(tbl2) & vbCrLf & "Dim 2 : " & UBound(tbl2, 2)
End Sub

Sub testrange1()
    Dim tbl, tbl2
    tbl = Range("A1:A20")
    texte = "Avant" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2) & vbCrLf
    tbl = TransposeX(tbl)
    MsgBox texte & "Apres" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2)
End Sub

Sub testrange2()
    Dim tbl, tbl2
    tbl = Range("A1:t1")
    texte = "Avant" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2) & vbCrLf
    tbl = TransposeX(tbl)
    MsgBox texte & "Apres" & vbCrLf & "Dim 1 : " & UBound(tbl) & vbCrLf & "Dim 2 : " & UBound(tbl, 2)
End Sub


Function TransposeX(t)
    'patricktoulon    V 1.2 -- 08/07/2021
    Dim y&, i&, c&, t2
    On Error Resume Next
    y = UBound(t, 2)
    On Error GoTo 0
    If y = 0 Then
        ReDim t2(LBound(t) To UBound(t), 1)
    Else
        ReDim t2(LBound(t, 2) To UBound(t, 2), LBound(t) To UBound(t))
    End If
    For i = LBound(t) To UBound(t)
        If y = 0 Then
            t2(i, 1) = t(i)
        Else
            For c = LBound(t, 2) To UBound(t, 2): t2(c, i) = t(i, c): Next
        End If
    Next
    TransposeX = t2
End Function

Function TransposeX(x)
If Not IsArray(x) Then TransposeX = x: Exit Function
Dim a, Lb1, Ub1, Lb2, Ub2, b(), i, j
a = x
Lb1 = LBound(a): Ub1 = UBound(a)
Lb2 = LBound(a, 2): Ub2 = UBound(a, 2)
ReDim b(Lb2 To Ub2, Lb1 To Ub1)
For i = Lb2 To Ub2
    For j = Lb1 To Ub1
        b(i, j) = a(j, i)
Next j, i
TransposeX = b 'matrice
End Function

' ====================
'  Swap Dim 1 / Dim 2
' ====================
 ReDim Temp1(LBound(Tablo_arr, 2) To UBound(Tablo_arr, 2), LBound(Tablo_arr, 1) To UBound(Tablo_arr, 1))
  For I = LBound(Tablo_arr, 1) To UBound(Tablo_arr, 1)
    For J = LBound(Tablo_arr, 2) To UBound(Tablo_arr, 2)
      If IsObject(Tablo_arr(I, J)) Then
        Set Temp1(J, I) = Tablo_arr(I, J)
      Else
        If IsDate(Tablo_arr(I, J)) Then
          Temp1(J, I) = Tablo_arr(I, J)
        Else
          Temp1(J, I) = Tablo_arr(I, J)
        End If
      End If
    Next J
  Next I

Option Base 1
Sub test()
    Dim tbl
    tbl = Array("toto", "titi", "riri", "fifi")
    MsgBox tbl(1)
    MsgBox LBound(tbl)
End Sub

Function TransposeX(x)
If Not IsArray(x) Then TransposeX = x: Exit Function
Dim a, Lb1, Ub1, Lb2, Ub2, e As Boolean, b(), i, j
a = x
Lb1 = LBound(a): Ub1 = UBound(a)
On Error Resume Next 'car erreur si a est de dimension 1
Lb2 = LBound(a, 2): Ub2 = UBound(a, 2)
If Err Then
    ReDim b(Lb1 To Ub1, 0 To 0)
    For i = Lb1 To Ub1
        b(i, 0) = a(i)
    Next i
Else
    ReDim b(Lb2 To Ub2, Lb1 To Ub1)
    For i = Lb2 To Ub2
        For j = Lb1 To Ub1
            b(i, j) = a(j, i)
    Next j, i
End If
TransposeX = b 'matrice
End Function