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

k = LBound(t, 1) - 1
p = LBound(t, 2) - 1
For i = 1 To ni
    For j = 1 To nj
        r(j, i) = t(k + i, p + j)
    Next j
Next i

k = LBound(t, 1)
For i = 1 To ni
    p = LBound(t, 2)
    For j = 1 To nj
        r(j, i) = t(k, p)
        p = p + 1
    Next j
    k = k + 1
Next i

ReDim Tablo([B]1[/B] To 5000, [B]0[/B] To 1000)    '50 millions de données
'''''''''
' Remplir avec du TEXTE
  If QDim = 2 Then
    For I = LBound(Tablo) To UBound(Tablo)
      For J = LBound(Tablo, 2) To UBound(Tablo, 2)
        Tablo(I, J) = CStr(I) & ", " & CStr(J)
      Next J
    Next I
  Else
    For I = LBound(Tablo) To UBound(Tablo)
      Tablo(I) = CStr(I)
    Next I
  End If
'''''''''

'- BaseOut1 : Optionnel - 0 ou 1 ou autre valeur selon le LBound souhaitée de la 1ère dimension du tableau transposé
'             xlNone pour utiliser le LBound de la 2ème dimension de t
'- BaseOut2 : Optionnel - 0 ou 1 ou autre valeur selon le LBound souhaitée de la 2ème dimension du tableau transposé
'             xlNone pour utiliser le LBound de la 1ère dimension de t

'VERSION 1
Function TransposeXV1(T, Optional lBase1& = -1, Optional lBase2& = -1)
    'patricktoulon    V 1.2 -- 08/07/2021
    'Ajout du change base V 1.2.1 -- 08/12/2024  méthode Addition nombre relatif
    Dim y&, i&, C&, T2(), LB1%, LB2%
    If TypeOf T Is Range Then T = T.Value
    If Not IsArray(T) Then TransposeXV1 = T
    If lBase1 > 1 Then lBase1 = 1 ' au cas ou il vous prendrez l'envie de faire nimporte quoi
    If lBase2 > 1 Then lBase2 = 1 ' au cas ou il vous prendrez l'envie de faire nimporte quoi
    On Error Resume Next
    y = UBound(T, 2)
    On Error GoTo 0
    'b1 et b2 deviendront les reducteurs ou augmenteur de dimension (++/+-)
    If lBase1 > -1 Then LB1 = Sgn(lBase1 - LBound(T))
    If y = 0 Then
        ReDim T2(LBound(T) + LB1 To UBound(T) + LB1, LBound(T) + LB1 To LBound(T) + LB1)
    Else
        If lBase2 > -1 Then LB2 = Sgn(lBase2 - LBound(T, 2))
        ReDim T2(LBound(T, 2) + LB2 To UBound(T, 2) + LB2, LBound(T) + LB1 To UBound(T) + LB1)
    End If
    For i = LBound(T) To UBound(T)
        If y = 0 Then
            T2(i + LB1, 1) = T(i)
        Else
            For C = LBound(T, 2) To UBound(T, 2)
                T2(C + LB2, i + LB2) = T(i, C)
            Next
        End If
    Next
    TransposeXV1 = T2
End Function

'VERSION 2
Function TransposeXV2(T, Optional lBase1& = -1, Optional lBase2& = -1)
    'Ajout du change base V 1.2.1 -- 08/12/2024  méthode Addition nombre relatif en select case
    'patricktoulon    V 1.3 -- 10/12/2024
    'version 1.3 avec un select case
    Dim y&, i&, C&, T2(), LB1%, LB2%
    If TypeOf T Is Range Then T = T.Value
    If Not IsArray(T) Then TransposeXV2 = T
    If lBase1 > 1 Then lBase1 = 1 ' au cas ou il vous prendrez l'envie de faire nimporte quoi
    On Error Resume Next
    y = UBound(T, 2)

    'b1 et b2 deviendront les reducteurs ou augmenteur de dimension (++/+-)

    Select Case True
        Case Err.Number <> 0
            If lBase1 > -1 Then LB1 = Sgn(lBase1 - LBound(T))
            ReDim T2(LBound(T) + LB1 To UBound(T) + LB1, LBound(T) + LB1 To LBound(T) + LB1)
            For i = LBound(T) To UBound(T): T2(i + LB1, 1) = T(i): Next
            On Error GoTo 0
        Case Else
            If lBase2 > -1 Then LB2 = Sgn(lBase2 - LBound(T, 2))
            ReDim T2(LBound(T, 2) + LB2 To UBound(T, 2) + LB2, LBound(T) + LB1 To UBound(T) + LB1)
            For i = LBound(T) To UBound(T)
                For C = LBound(T, 2) To UBound(T, 2): T2(C + LB2, i + LB2) = T(i, C): Next
            Next
    End Select
    TransposeXV2 = T2
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&
    If Not IsArray(T) Then ConvertTo2Dim= T
    If GetTypeArray(T) > 1 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

'FONCTION POUR DETERMINER LE TYPE D ARRAY(1 ou 2 dim)
Function GetTypeArray(T)
    'patricktoulon    V 1.0 -- 06/12/2024
    Dim U2
    If Not IsArray(T) Then GoSub Errorx
    On Error Resume Next
    U2 = UBound(T, 2)
    If Err Then
        GetTypeArray = 1
        On Error GoTo 0
    Else
        GetTypeArray = 2
    End If
    Exit Function
Errorx:     Err.Raise Number:=2002, Description:="Fonction : GetTypeArray" & vbCrLf & "L'argument reçu n'est pas un array ."
End Function

'- t            : Range ou Table à 1 ou 2 dimensions ou une valeur
'- BaseOut1     : Optionnel - 0 ou 1 ou autre valeur selon le LBound souhaitée de la 1ère dimension de la table transposée
'                 Par défaut: xlNone pour utiliser le LBound de la 2ème dimension de la table t
'- BaseOut2     : Optionnel - 0 ou 1 ou autre valeur selon le LBound souhaitée de la 2ème dimension de la table transposée
'                 Par défaut: xlNone pour utiliser le LBound de la 1ère dimension de la table t
'- NoTranspose  : Optionel - True pour ne pas transposer une table à 1 dimension et seulement lui rajouter une 2ème dimension
'                 Par défaut: False
'- Return       : Table à 2 dimensions transposée de t (sauf cas NoTranspose = True)