'--------------------------------------------------------------------
'Fonction de Tranpose selon la logique de WorksheetFunction.Transpose
'sauf que WorksheetFunction.Transpose se limite à 65536 éléments
'alors que cette fonction lève cette limite.
'--------------------------------------------------------------------
Function TransposeExcel(t As Variant) As Variant
Dim tt() As Variant
Dim NbDimensions As Integer
Dim i As Long
Dim j As Long
If Not IsArray(t) Then
MsgBox "Function TransposeExcel: error argument is not an array !"
Exit Function
End If
'1 ou 2 dimensions pour t ?
On Error Resume Next
i = UBound(t, 2)
If Err.Number Then NbDimensions = 1 Else NbDimensions = 2
On Error GoTo 0
'------------------------------------------------------
'Tableau origine 1 dimension
'=> Tableau destination 2 dimensions dont la 2ème est 1
'------------------------------------------------------
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 i
End If
'----------------------------
'Tableau origine 2 dimensions
'----------------------------
If NbDimensions = 2 Then
'-----------------------------------------------
'Tableau origine 2 dimensions dont la 2ème est 1
'=> Tableau destination 1 dimension
'-----------------------------------------------
If UBound(t, 2) = LBound(t, 2) Then
ReDim tt(LBound(t, 1) To UBound(t, 1))
For i = LBound(t, 1) To UBound(t, 1)
tt(i) = t(i, 1)
Next i
'-------------------------------------------------
'Tableau origine 2 dimensions dont la 2ème est > 1
'=> Tableau destination 2 dimensions inversées
'-------------------------------------------------
Else
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
End If
TransposeExcel = tt
End Function
'------------------------------------------------------------------
'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.
'------------------------------------------------------------------
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
'1 ou 2 dimensions pour t ?
On Error Resume Next
i = UBound(t, 2)
If Err.Number Then NbDimensions = 1 Else NbDimensions = 2
On Error GoTo 0
't est un tableau à 1 dimension
If NbDimensions = 1 Then
TransposeNaturel = t
'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
TransposeNaturel = tt
End If
End Function