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

 ON Error Goto 0

'Retourne le nombre de dimensions d'un tableau
Public Function CountArrayDim(aArray As Variant) As Variant
Dim I
Dim Rep
Dim MyErr

  On Error GoTo ErrHandler
'''''
' Test if is an Array
'''''
  If IsArray(aArray) Then
' Loop until an error occur
    Do
        I = I + 1
        Rep = LBound(aArray, I)
    Loop Until MyErr <> 0
    CountArrayDim = I - 1
    Exit Function
  Else
    CountArrayDim = 0 'CVErr(xlErrRef) ' 0 ==> IT'S NOT AN ARRAY
  End If
  CountArrayDim = 0
Exit Function

ErrHandler:
' If an error  -> set the number of dimensions
  CountArrayDim = I - 1
  Err.Clear
End Function

Sub a()
    Dim TabValeurs() As Variant
    Dim ErrNumber As Long
 
    On Error Resume Next
    TabValeurs = ActiveSheet.Range("A1:A10").Value
    ErrNumber = Err.Number
    On Error GoTo 0
 
    If Not ErrNumber = 0 Then
        MsgBox "Impossible de charger la plage en table"
        Exit Sub
    End If
 
    MsgBox "Tout va bien !"
 
    'Code continue
    '.../...
End Sub

Dim bench As cBenchmark

Sub test2()
    Dim tx(1 To 50000, 1 To 100) 'même dimension que dudu2 avec application transpose
    Set bench2 = New cBenchmark

    bench2.TrackByName "debut de transposition avec vba transpose version patricktoulon"

    T2 = TransposeXV1(tx, 0)

    texte = "Avant" & vbCrLf & "base dim 1 : " & LBound(tx) & vbCrLf & "base dim 2 : " & LBound(tx, 2) & vbCrLf

    bench2.TrackByName "fin de transposition avec vba transpose version patricktoulon"

    MsgBox texte & "Après" & vbCrLf & "base dim 1 : " & LBound(T2) & vbCrLf & "base dim 2 : " & LBound(T2, 2)
End Sub


Function TransposeXV1(t, Optional lBase& = -1)
    'patricktoulon    V 1.2 -- 08/07/2021
    'Ajout du change base V1.2.1 -- 08/12/2024  méthode Addition nombre relatif
    Dim y&, i&, C&, T2(), b1&, b2&

    If lBase > 1 Then lBase = 0 ' au cas ou il vous prendrez l'envie de faire n'importe quoi

    On Error Resume Next
    y = UBound(t, 2)
    On Error GoTo 0

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

    If lBase > -1 Then b1 = Sgn(lBase - LBound(t))

    If y = 0 Then
        On Error GoTo 0
        ReDim T2(LBound(t) + b1 To UBound(t) + b1, LBound(t) + b1 To LBound(t) + b1)
    Else
        If lBase > -1 Then b2 = Sgn(lBase - LBound(t, 2))
        ReDim T2(LBound(t, 2) + b2 To UBound(t, 2) + b2, LBound(t) + b1 To UBound(t) + b1)

    End If

    For i = LBound(t) To UBound(t)
        If y = 0 Then
            T2(i + b1, 1) = t(i)
        Else
            For C = LBound(t, 2) To UBound(t, 2)
                T2(C + b2, i + b2) = t(i, C)
            Next
        End If
    Next

    TransposeXV1 = T2
End Function

Function TransposeXV1(t, Optional lBase& = -1)
    'patricktoulon    V 1.2 -- 08/07/2021
    'Ajout du change base V1.2.1 -- 08/12/2024  méthode Addition nombre relatif
    Dim y&, i&, C&, T2(), b1&, b2&
    If lBase > 1 Then lBase = 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 lBase > -1 Then b1 = Sgn(lBase - LBound(t))
    If y = 0 Then
        On Error GoTo 0
        ReDim T2(LBound(t) + b1 To UBound(t) + b1, LBound(t) + b1 To LBound(t) + b1)
    Else
        If lBase > -1 Then b2 = Sgn(lBase - LBound(t, 2))
        ReDim T2(LBound(t, 2) + b2 To UBound(t, 2) + b2, LBound(t) + b1 To UBound(t) + b1)
    End If
    For i = LBound(t) To UBound(t)
        If y = 0 Then
            T2(i + b1, 1) = t(i)
        Else
            For C = LBound(t, 2) To UBound(t, 2)
                T2(C + b2, i + b2) = t(i, C)
            Next
        End If
    Next
    TransposeXV1 = T2
End Function

Public dicStampName_ID As Object 'key = custom name, value = StampID
Public dID_colTicDiffs As Object 'key = IDnr, value = collection of time recordings (tics) per IDnr
Public dHeaders As Object 'dict to filter out unique ValueTypes out of dAll
Public dAll As Object 'temp to hold the values of the output report. key = IDnr concatenated with the ValueType

Private Sub Class_Initialize()
    QueryPerformanceFrequency freq 'frequency is set at computer boot, does not change after that
    freq = freq * fromCurr 'scale from Currency to whole number
    Set dicStampName_ID = CreateObject("scripting.dictionary") 'key = custom name, value = StampID
    dicStampName_ID.CompareMode = vbBinaryCompare 'faster then vbTextCompare, but difference in capital letters will matter
    Set dID_colTicDiffs = CreateObject("scripting.dictionary") 'key = IDnr, value = collection of time recordings (tics) per IDnr
    Set dHeaders = CreateObject("scripting.dictionary") 'dict to filter out unique ValueTypes out of dAll
    Set dAll = CreateObject("scripting.dictionary") 'temp to hold the values of the output report. key = IDnr concatenated with the ValueType

    Start 'Start stores the first QPC, which is filtered out in Sub Report
End Sub

public function ReportMessage()
'parti de là tu décortique tes dicos
end function