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

[p'tit vieux]

Bonjour à tous,
Pour mes codes VBA, j'ai écris une première version de ma fonction Transpose() que je vais mettre à votre disposition dans sa version 1.0.0.
Toutefois, je voudrais votre avis sur l'intérêt de rajouter des options complémentaires à celle-ci.

Dans un premier temps j'ai écris une fonction Transpose() afin de lever la limite des 65536 lignes de la fonction "WorkSheetFunctions.Transpose" d'Excel.
Pour mes besoins j'ai ajouté les possibilités suivantes:
- Choisir la base départ du tableau (Base 0 ou 1)
- Pouvoir convertir un texte/valeur simple dans un tableau 2D T(1,1)

Rien d'exceptionel, mais pratique.

Donc je vous propose de me soumettre vos idées.

Par exemple, j'ai pensé à:
- Si on transmet T(0 to 0, 0 to N) ou T(1 to N, 1 to 1) Transpose() renvoie un tableau 1D T(0 to N) ou T(1 to N) suivant la base choisie
- Transposer ET ne renvoyer que les n premieres lignes
- Transposer ET ne renvoyer de la ligne n° X à n° Y

Voilà pour ces quelques idées.
A votre avis laquelle ou lesquelles de celles-ci ont-elles un intérêt.

Et vous, vos autres idées qui vous paraitraient utiles?
Ensuite suivant vos propositions ….
Je nommerai un 1er Ministre du développement
Mais non! Je publierai une nouvelle version (Pas sérieux ces P'tit Vieux)

Merci pour vos avis et suggestions.

ATTENTION!
Ici il n'est pas question de faire des recherches de texte/valeur ou autre truc du genre.

 

[p'tit vieux]

Hello,
j'ai fait le test en mettant tout en Option Base 0 . Il y a un souci avec la fonction Application.Transpose : elle renvoie toujours des tableaux qui commencent à 1.
Ami calmant, K.P

Bonsoir tous,
Désolé de vous avoir abandonné sur mon propre sujet.
Je ne fais qu'un petit tour en vitesse car peu de temps en ce jour.
Je ne m'attendais pas un tel succès

@Jurassic
Pour Application.Transpose c'est "normal". Cela fait parti des défaut. Regarde plus haut les capture d'écran que j'ai faites en Poste 8 pour avoir une idée

 

[p'tit vieux]

Comme je n'aime les

 ON Error Goto 0

qui se promène je vous met ce bout de code qui évite cela.
C'est tout bête, il retourne le nombre de dimensions d'un tableau.
Si ce n'est pas tableau il retourne 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

J'ai récupéré le code BenchMark pour faire des tests comme vous.
Faute de temps, je n'ai pas terminé de faire quelques modifications et vous le transmettre.

Vu le sujet ca va être une FONCTION DE COMPETITION

Une chose est certaine c'est que vous êtes investis
OK aussi c'est normal pour des … DIEUX

Je vous dis à demain et vous souhaite une bonne fin de week-end

PS:
On ne s'énerve pas hein! … enfin pas le dimanche.

@patrick
Message perso:
On est calme. On n'appelle pas tes copains George et Hubert …
enfin peut-être ne sont ils plus à Saint Mandrier.
(Je les connaissais)

 

[Dudu2]

@p'tit vieux,

Les On Error génériques qui plongent dans un "error handler" tonneau des Danaïdes, perso, ça me plait pas du tout, du tout, du tout.

Hélas, parfois on n'a pas le choix que d'utiliser un On Error pour protéger une instruction particulière.
Il faut absolument limiter le On Error à cette instruction ou ce contexte très limité pour garder le contrôle.

Sinon ça veut dire qu'on ne maitrise pas son code et qu'on s'attend à récupérer des erreurs n'importe où au petit bonheur la malchance.

Exemple de On Error limité à une instruction:

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

 

[patricktoulon]

@Dudu2
ben a quoi ça sert que je teste ,puisque tu me crois pas quand je te montre ce que font tes fichiers
et que mes vidéos sont trop longues qui pourtant te montre sans artifice la vérité nues
allez je reprend ma version originale et lui ajoute un Argument "lBase" pour pouvoir lui changer la base dynamico
là encore une fois pas la peine d'en faire une tartine

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

le résultat est sans appel 397 microsecondes pour 50000 sur 100

 

[Dudu2]

Ok, ça sert à rien que Ducros y se décarcasse. Je laisse tomber ce dialogue de sourds j'ai envie de dire habituel.

Comme d'hab tu ne t'es même pas intéressé au fichier que j'ai fourni. Tu ne t'intéresses qu'à ton code dont j'ai démontré qu'il n'apporte rien par rapport au mien ou au code de tout autre personne qui ferait la même chose c'est à dire copier des tables.

Quant à ta prétention d'aller 10 fois plus vite j'ai déjà expliqué que c'est complètement farfelu et déraisonnable car les algorithmes de recopie de tables sont identiques à la présentation près.
Comment veux-tu que des codes similaires aient un rapport de performance de 1 à 10 ?

 

[patricktoulon]

j'ai démontré qu'il n'apporte rien par rapport au mien

rectification
tu es arrivé après moi dans cette discussion et tu n'a apporté rien de nouveau
et si je teste pas ton dernier fichier c'est par ce que tu me prend pour un citron quand je te montre les captures
presque tu me traite de menteur alors que les vidéos film mon écran tel que ça se passe
tu raconte n'importe quoi et je pense que c'est toi qui est plus intéressé par tes propres codes

et moi comme un con je prend le temps de tout te montrer dans les vidéos
je suis vraiment bête de te porter finalement un intérêt quelconque car à chaque fois tu te retranche dans une démagogie de politiciens

 

[Dudu2]

Et pour me faire plaisir, puisque j'ai bossé pour ça, les résultats que j'obtiens avec le fichier que j'ai fourni.
Ça ne s'adresse pas @patricktoulon qui fait un code qui va 10 fois plus vite !

 

[patricktoulon]

a ben tien comme par hasard maintenant on est pareil alors que tu disais que c’était mon truc chez toi qui mettait 9 secondes
tu vois bien que c'est toi qui t’emmêle les pinceaux
et à comparer compare au moins avec les mêmes dimensions sinon ça n'a pas de sens
je dis ça comme ça hein je te force à rien

 

[patricktoulon]

allez va pour te faire plaisir

alors quand tu dis que j'apporte rien de nouveau et que c'est toi qui arrivé le dernier dans la discussion
et que donc tu est le dernier a y participer et que finalement
on arrive a des temps quasiment identiques (a ce niveau là ca vaut même pas la peine de comparer)
alors que je fait ces même temps depuis le debut avec un code simple que même un bébé pourrait comprendre alors que dans code une chatte n'y retrouverait pas ses petits
je me dis soit tu me chambre soit tu me prend pour un citron

tout ce que tu fait avec tout lcode de ta fonction ,je le fait avec ceci

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

et c'est pas du code spaghetti
moi ce qui me ferait plaisir c'est que tu prenne le temps de regarder le code
de le comprendre et te rendre compte a quel point tu fait des tas de choses inutiles dans tes codes
même si tu me dit pas que j'ai raison je m'en fou en fait
mais que tu puisse te poser les bonnes questions
par exemple
pour quoi
le code de patricktoulon de 22 lignes(sans commentaires et déclarations de variable) que même un débutant pourrait déchiffrer facilement

fait la même chose

qu'un code à la DUDU2 de 67 lignes sans les commentaire et sans les déclarations de variable dans le quel une chatte ne retrouvera pas ses petits

 

[Dudu2]

Mais oui mon @patricktoulon, c'est bien sûr, le modèle de code à suivre c'est la tien et le mien n'est qu'un nœud gordien chaque fois renouvelé, une intrication quasi-quantique où on ne peut déterminer la position et la vitesse des objets qui y figurent. On y croit !

Sinon, avez-vous remarqué que dans ce code enchevêtré et instable, il y a une petite ressource TRÈS intéressante pour remplacer le MsgBox et faire de jolies choses très variées ? C'est le Custom MsgBox. Sans lui, pas de présentation des résultats bien ajustée et bien lisible.

Tiens, j'avais d'ailleurs oublié de le positionner pour pas qu'il s'affiche partiellement sur le tableau.
C'est corrigé dans ce fichier.

 

[patricktoulon]

je ne commenterais pas le msgbox perso je n'ai pas regardé
ce que j'ai vu par contre c'est les ctrl+a+c dans le debug ce qui implique une ouverture du debug etc.....
il y a avais un moyen plus simple de récupérer les string des lignes du message de report en allant taper directement dans le cbenchmark en faisant quelques modifs ,c’était pas de la tarte je le reconnais
mais comme tu es super fort tu y arrivera

 

[Dudu2]

Tu veux dire aller dans la Classe pour récupérer les infos ?
Oui, j'y ai pensé mais je ne voulais pas trop modifier ce code de Microsoft Github.
Je suis super fort

, c'est vrai, surtout en thème, mais moins que toi quand même... Faut pas exagérer.

D'ailleurs tu me fais penser qu'au lieu de faire du code VBA et polémiquer avec toi, je ferais mieux de me ré-inscrire à la salle.

 

[jurassic pork]

Tu veux dire aller dans la Classe pour récupérer les infos ?
Oui, j'y ai pensé mais je ne voulais pas trop modifier ce code de Microsoft Github.

Hello,
le créateur de cBenchmark n'a pas mis de Licence pour son code et il n'a plus l'air de s'en occuper.
J'ai fait quelques modifs dans son code :
1 - En déclarant les Dictionnaires en Objet pour ne plus avoir à cocher la case Microsoft Scripting Runtime dans les Références
2 - Sortie des résultats dans une feuille en complément de la fenêtre d'exécution : si la Cellule nommée Benchmark existe dans le classeur on Affiche les résultats à partir de cette cellule. Comme cela pour montrer les résultats dans le forum, plus la peine d'utiliser une copie d'écran, un copier coller de la plage suffit.
Exemple :

IDnr	Name	Count	Sum of tics	Percentage	Time sum
0​	Init Table	2​	2 244 719	33,48%	224 ms
1​	Application.Transpose	1​	2 631 922	39,25%	263 ms
2​	VBA Transpose	1​	1 828 164	27,27%	183 ms
	TOTAL	4​	6 704 805	100,00%	670 ms

Si ça vous intéresse je met à disposition le classeur de test avec le module de classe cBenchmark modifié. Le souci c'est comme il n'y a pas de licence sur le code, je ne peux pas trop mettre le code modifié directement à disposition.
Ami calmant, J.P

 

[Dudu2]

Bonjour @jurassic pork,
Envoie ta classe, ça m'intéresse.
Je suppose que tu en as fait une Table avant de le placer en feuille.
J'aimerais récupérer le résultat en variable String et Table si possible.

 

[patricktoulon]

Bonjour
c'est pas compliqué
tu declare tes dictionnaires en object et tu les crée en late binding
pour cela tu les enleve des fonction dans les quelles ils sont et tu les declare en globale module
comme ceci

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

ensuite tu les crée dans le initialise

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

te reste plus qu'a ajouter une fonction (EN PUBLIC)car la on sera en lecture a partir de la macro avec les trackname
par exemple

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

veille bien a les enlenver des fonctions ou ils étaient bien évidemment

et a la fin de la macro ou ils y a les appels trackbyname
tu fait msgbox bench.Reportmessage
bench étant l'instance de la classe instanciée
terminé
Patrick