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

'savoir les dimensions              on fait une fonction

'connaitre le base                  on fait une fonction

'changer le base                    on fait une fonction

'transposer sans limite             on fait une fonction

'merger deux tableaux ou plus       on fait une fonction

 If NbDimensions = 1 Then
        TransposeNaturel = t

'FONCTION DE SUBSTITUTION DE LA FONCTION TRANSPOSE DE EXCEL
Function TransposeX(T As Variant) As Variant
    'patricktoulon    V 1.2 -- 08/07/2021
    'remastered by patricktoulon V1.3 -- 06/12/2024
    'déportation du redimensionnement 1D to 2D dans la fonction ConvertTo2Dim
    Dim T2() As Variant, i&, c&, Y&
    On Error Resume Next
    Y = UBound(T, 2)
    On Error GoTo 0
    If Y = 0 Then T = ConvertTo2Dim(T) ' Si t est un tableau 1 Dim, convertir en 2D [[[dans le même sens]]]

    ReDim T2(LBound(T, 2) To UBound(T, 2), LBound(T) To UBound(T)) ' Redimensionner t2 pour transposer t
    For i = LBound(T) To UBound(T)
        For c = LBound(T, 2) To UBound(T, 2): T2(c, i) = T(i, c): Next c
    Next i
    TransposeX = T2 'Return
End Function

'FONCTION DE CONVERSION  D'UN ARRAY VERS TABLEAU 2 DIM
Function ConvertTo2Dim(ByVal T As Variant) As Variant
    'patricktoulon    V 1.0 -- 06/12/2024
    Dim T2(), i&, Y&
    On Error Resume Next
    Y = UBound(T, 2)
    On Error GoTo 0
    If Y > 0 Then ConvertTo2Dim = T: Exit Function
    ReDim T2(LBound(T) To LBound(T), LBound(T) To UBound(T))
    For i = LBound(T) To UBound(T): T2(LBound(T), i) = T(i): Next i
    ConvertTo2Dim = T2
End Function

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

Sub a()
    'Dim t(1 To 1) As Variant
    Dim t() As Variant
    Dim tt() As Variant
 
    tt = TransposeNaturel(t)
    If Not (Not tt) Then MsgBox "Pas vide" Else MsgBox "Vide"
End Sub

'------------------------------------------------------------------
'Transpose "naturel" qui évite la réduction du nombre de dimensions
'lors de l'utilisation de WorksheetFunction.Transpose().
'Cette fonction conserve les 2 dimensions dans tous les cas et
'lève la limite de 65535 items de WorksheetFunction.Transpose().
'------------------------------------------------------------------
Function TransposeNaturel(t As Variant) As Variant
    Dim NbDimensions As Integer
    Dim tt() As Variant
    Dim i As Long
    Dim j As Long
  
    If Not IsArray(t) Then
        MsgBox "Function TransposeNaturel: error argument is not an array !"
        Exit Function
    End If

    '-----------------------------
    '0, 1 ou 2 dimensions pour t ?
    '-----------------------------
    On Error Resume Next
    i = UBound(t, 1)
    If Not Err.Number = 0 Then
        NbDimensions = 0
    Else
        i = UBound(t, 2)
        If Not Err.Number = 0 Then
            NbDimensions = 1
        Else
            NbDimensions = 2
        End If
    End If
    On Error GoTo 0

    '------------------------------
    't est un tableau à 1 dimension
    '------------------------------
    If NbDimensions = 1 Then
        ReDim tt(LBound(t) To UBound(t), 1 To 1)
      
        For i = LBound(t) To UBound(t)
            tt(i, 1) = t(i)
        Next

    '-------------------------------  
    't est un tableau à 2 dimensions
    '-------------------------------
    ElseIf NbDimensions = 2 Then
        ReDim tt(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
      
        For i = LBound(t, 2) To UBound(t, 2)
            For j = LBound(t, 1) To UBound(t, 1)
                tt(i, j) = t(j, i)
            Next j
        Next i
    End If

    '------------  
    'Return value
    '------------
    TransposeNaturel = tt
End Function

Function JoinSuiteArray(ParamArray q() As Variant) As Variant
    Dim p&, it As Variant, x&, t3() As Variant, h
    For p = LBound(q) To UBound(q)
        If IsArray(q(p)) Then
         

            For Each it In q(p)
                x = x + 1: ReDim Preserve t3(1 To x): t3(x) = it
            Next it
        Else
            GoTo error2
        End If
    Next
    JoinSuiteArray = t3
    Exit Function

error2:
    Err.Raise Number:=1001, _
                    Description:="L'argument n ° " & p + 1 & " n'est pas un array. " & vbCrLf & _
                    "Fonction : JoinSuiteArray. " & vbCrLf & _
                    "Correction : Vérifiez que tous les arguments sont des array à 1 dimension."
    Exit Function
End Function

Sub testjoinSuitearray()
    t = Array(1, 2, 3, 4, 5, 6)
    tx = Array(7, 8, 9, 10)
    Dim tm(1 To 5, 1 To 5)
    tf = JoinSuiteArray(t, tx, tm)
    MsgBox Join(tf, ";")
End Sub