Optimisation d'une fonction VBA

Le 23/10/2019 à 16:28

Bonjour à tous,

J'ai réalisé une fonction qui ... fonctionne, mais qui ralentit beaucoup le moindre filtre sur mon tableau.

Auriez-vous de pistes d'optimisation ?

Dans les trucs choquants : Pas de déclarations de variables ?

Dans les trucs bizarres : Si je met le nom de la colonne en référence, ça ne fonctionne pas. Je dois mettre le N° de la cellule

=SlaToTime(A1) au lieu de =SlaToTime([Colonne1])

Merci à vous,

Dans une colonne A j'ai des valeurs de temps codés n'importe comment, mais toujours de la même façon : (Le "-" est important)

  • 6min
  • 38min
  • 1h
  • 10h
  • 8h 4m
  • 3h 17m
  • 12h 8m
  • 15h 59m
  • 3d
  • 1d 3h
  • 1d 29h
  • 1w
  • 1w 4d

Dans une colonne B j'utilise ma fonction de cette façon :

=SlaToTime(A1)

Function SlaToTime(ExtraSla)

If Left(ExtraSla, 1) = "-" Then 'Si on commence par -

If InStr(ExtraSla, "h") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * 4.16666666666667E-02 '1h

If InStr(ExtraSla, "h") And Len(ExtraSla) = 4 Then SlaToTime = Mid(ExtraSla, 2, 2) * 4.16666666666667E-02 '11h

If InStr(ExtraSla, "m") And Not InStr(ExtraSla, "min") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * 4.16666666666667E-02 + Mid(ExtraSla, 5, 1) * 6.94444444444444E-04 '1h 1m

If InStr(ExtraSla, "m") And Len(ExtraSla) = 7 And Mid(ExtraSla, 3, 1) = "h" Then SlaToTime = Mid(ExtraSla, 2, 1) * 4.16666666666667E-02 + Mid(ExtraSla, 5, 2) * 6.94444444444444E-04 '1h 11m

If InStr(ExtraSla, "m") And Len(ExtraSla) = 7 And Mid(ExtraSla, 4, 1) = "h" Then SlaToTime = Mid(ExtraSla, 2, 2) * 4.16666666666667E-02 + Mid(ExtraSla, 6, 1) * 6.94444444444444E-04 '11h 1m

If InStr(ExtraSla, "m") And Len(ExtraSla) = 8 Then SlaToTime = Mid(ExtraSla, 2, 2) * 4.16666666666667E-02 + Mid(ExtraSla, 6, 2) * 6.94444444444444E-04 '11h 11m

If InStr(ExtraSla, "d") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1 '1d

If InStr(ExtraSla, "d") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1 + Mid(ExtraSla, 5, 1) * 4.16666666666667E-02 '1d 1h

If InStr(ExtraSla, "d") And Len(ExtraSla) = 7 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1 + Mid(ExtraSla, 5, 2) * 4.16666666666667E-02 '1d 29h

If InStr(ExtraSla, "w") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * 7 '1w

If InStr(ExtraSla, "w") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * 7 + Mid(ExtraSla, 5, 1) * 1 '1w 1d

If InStr(ExtraSla, "min") And Len(ExtraSla) = 5 Then SlaToTime = Mid(ExtraSla, 2, 1) * 6.94444444444444E-04 '1min

If InStr(ExtraSla, "min") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 2) * 6.94444444444444E-04 '11min

Else: SlaToTime = ""

End If

End Function

31opti.xlsm (16.56 Ko)
Le 23/10/2019 à 17:16

Bonjour,

Voici ton classeur où j'ai utilisé deux constantes, une pour la minute et une pour l'heure. J'ai aussi entré la formule pour le tableau afin quelle soit recopiée automatiquement à chaque ajout de ligne :

4opti-version-2.xlsm (18.58 Ko)
Le 23/10/2019 à 17:32

Bonjour,

Tu peux ajouter un exit function dès que tu as fait une évaluation de slatotime pour éviter que vba ne passe en revue tous les autres tests inutilement, (gain de 10%-20%), mais je doute que tu en voies les effets sur ton filtre.

A part cela et la proposition de Theze, en terme de performance et si les cas à envisager sont uniquement ceux que tu testes dans ton code, il me semble difficile d'améliorer sensiblement les performances.

ainsi

Function SlaToTime(ExtraSla)

    Const H As Single = 1 / 24 'heure
    Const M As Single = 1 / 1440 'minute

    If Left(ExtraSla, 1) = "-" Then 'Si on commence par -

        If InStr(ExtraSla, "h") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * H: Exit Function '
        If InStr(ExtraSla, "h") And Len(ExtraSla) = 4 Then SlaToTime = Mid(ExtraSla, 2, 2) * H: Exit Function '
        If InStr(ExtraSla, "m") And Not InStr(ExtraSla, "min") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * H + Mid(ExtraSla, 5, 1) * M: Exit Function '1h 1m
        If InStr(ExtraSla, "m") And Len(ExtraSla) = 7 And Mid(ExtraSla, 3, 1) = "h" Then SlaToTime = Mid(ExtraSla, 2, 1) * H + Mid(ExtraSla, 5, 2) * M: Exit Function '1h 11m
        If InStr(ExtraSla, "m") And Len(ExtraSla) = 7 And Mid(ExtraSla, 4, 1) = "h" Then SlaToTime = Mid(ExtraSla, 2, 2) * H + Mid(ExtraSla, 6, 1) * M: Exit Function '11h 1m
        If InStr(ExtraSla, "m") And Len(ExtraSla) = 8 Then SlaToTime = Mid(ExtraSla, 2, 2) * (1 / 24) + Mid(ExtraSla, 6, 2) * H: Exit Function '11h 11m
        If InStr(ExtraSla, "d") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1: Exit Function '1d
        If InStr(ExtraSla, "d") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1 + Mid(ExtraSla, 5, 1) * H: Exit Function '1d 1h
        If InStr(ExtraSla, "d") And Len(ExtraSla) = 7 Then SlaToTime = Mid(ExtraSla, 2, 1) * 1 + Mid(ExtraSla, 5, 2) * H: Exit Function '1d 29h
        If InStr(ExtraSla, "w") And Len(ExtraSla) = 3 Then SlaToTime = Mid(ExtraSla, 2, 1) * 7: Exit Function '1w
        If InStr(ExtraSla, "w") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 1) * 7 + Mid(ExtraSla, 5, 1) * 1: Exit Function '1w 1d
        If InStr(ExtraSla, "min") And Len(ExtraSla) = 5 Then SlaToTime = Mid(ExtraSla, 2, 1) * M: Exit Function '1min
        If InStr(ExtraSla, "min") And Len(ExtraSla) = 6 Then SlaToTime = Mid(ExtraSla, 2, 2) * M: Exit Function '11min

    Else

        SlaToTime = ""

    End If

End Function
Le 23/10/2019 à 17:48

Bonjour,

à tester

Pas sûr qu'il y a un gain conséquent mais c'est sous cette forme que je l'aurais écrite.

Const dur_m As Double = 1 / 24 / 60
Const dur_h As Double = 1 / 24
Const dur_d As Double = 1
Const dur_w As Double = 7

Function SlaToTime(ExtraSla) As Double
    Dim tmp, i As Long, v As Double
    If Left(ExtraSla, 1) = "-" Then
        tmp = Split(Replace(Mid(ExtraSla, 2), "min", "m"), " ")
        For i = 0 To UBound(tmp)
            v = CLng(Left(tmp(i), Len(tmp(i)) - 1))
            Select Case Right(tmp(i), 1)
            Case "m"
                SlaToTime = SlaToTime + v * dur_m
            Case "h"
                SlaToTime = SlaToTime + v * dur_h
            Case "d"
                SlaToTime = SlaToTime + v * dur_d
            Case "w"
                SlaToTime = SlaToTime + v * dur_w
            Case Else
                SlaToTime = 99999
            End Select
        Next i
    End If
End Function

Pour garder la fonction As Double je retourne 0 au lieu de "", et 99999 en cas d'anomalie.

Sinon la déclarer Variant

eric

PS : une mesure sur 1000 lignes donne 2 à 3 fois plus rapide.

Le 23/10/2019 à 18:19

Bonjour Eriiic,

j'avais un code quasi identique (hormis le double) et j'arrivais à une diminution des performances (de 0.03 à .06 pour 15000 lignes). Je dois m'être planté quelque part.

Le 23/10/2019 à 19:49

Bonjour h2so4,

si tu utilises RefTreeAnalyser pour mesurer, il donne des indications erronées.

Ma petite proc pour mesurer :

Sub test()
    Dim t As Single
    t = Timer
    [B2:B1001].Dirty
    [B2:B1001].Calculate
    Do
    Loop Until Application.CalculationState = xlDone
    Debug.Print Timer - t
    '
    t = Timer
    [D2:D1001].Dirty
    [D2:D1001].Calculate
    Do
    Loop Until Application.CalculationState = xlDone
    Debug.Print Timer - t
End Sub

Je ne pense pas que ce soit seulement le function As Double qui fasse l'écart

eric

Le 24/10/2019 à 12:41

Merci à tous de vos réponses,

Les constantes ont l'avantage d’éclaircir le code, et l'ajout d'Exit accélère un peu l’exécution.

Le code proposé par eriiic et Top, c'est ce que j'aurai aimé être capable de faire.

Ce code est un peu plus rapide (Sur 5000 lignes, 4 colonnes sources et 4 colonnes cibles) mais le moindre filtre sur une colonne annexe relance tous les calculs pendant 10 à 15 secondes.

Le plus frustrant est que mon approche initiale, par formule , est le plus rapide, et de loin, mais c'est tellement laid ...

Et tous les choix ne sont pas encore pris en compte.

Encore merci, je continue à creuser,

Calcul sur h et m, min par défaut, et erreur sur d et w, (w et d sont plus rares ...)

=SI(GAUCHE([ColonneA];1)="-";SI(NON(ESTERREUR(CHERCHE("h";[ColonneA])));STXT([ColonneA];2;CHERCHE("h";[ColonneA])-2)*0,0416666666666667+STXT([ColonneA];CHERCHE(" ";[ColonneA]);NBCAR([ColonneA])-CHERCHE("h";[ColonneA])-1)*0,000694444444444444;STXT([ColonneA];2;CHERCHE("m";[ColonneA])-2)*0,000694444444444444);"")
Le 24/10/2019 à 13:09

Bonjour,

l'avantage des formules c'est qu'elles sont multi-thead, excel en calcule 4 ou 8 en même temps

Si tu as la formule tu peux combiner les 2.

Coller les formules en une fois sur la plage, attendre la fin du calcul avec

    Do
    DoEvents
    Loop Until Application.CalculationState = xlDone

et finir avec un .value=.value sur ta plage.

Ou bien tout calculer en mémoire dans un tableau que tu colles en une fois. Ca sera rapide également.

Par contre, l'un comme l'autre nécessite une maj manuelle ou sur un événement

Mais bon, il n'y a pas de formules moches, il y a celles qui fonctionnes et les autres

eric

Le 24/10/2019 à 13:19

Bonjour,

Surtout que tu as des valeurs peu réalistes : '-1d 29h ça ne serait pas plutôt '-2d 5h ?

Le 24/10/2019 à 13:26

Ah, je ne l'avais pas vue celle-là

Illustration du calcul en mémoire :

Sub test()
    Dim datas, result, lig As Long
    datas = [A2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1).Value
    ReDim result(1 To UBound(datas), 1 To 1)
    For lig = 1 To UBound(datas)
        If datas(lig, 1) <> "" Then result(lig, 1) = SlaToTime(datas(lig, 1))
    Next lig
    [D2].Resize(UBound(datas)) = result ' mis en D pour contrôle
End Sub

pour simplifier je fais appel à SlaToTime(). Si tu intègres (en adaptant) le code de la fonction dans la proc tu gagneras encore un peu. Mais comme ce n'est exécuté qu'une fois de temps en temps...

Tu peux faire une maj auto sur l'activation de la feuille ou un bouton

eric

Le 29/10/2019 à 11:48
Theze a écrit :

Bonjour,

Surtout que tu as des valeurs peu réalistes : '-1d 29h ça ne serait pas plutôt '-2d 5h ?

" Je sais...c'est une erreur." (R.Devos)

Hélas je ne maîtrise pas les données qui me sont fournis ...

Le 06/11/2019 à 13:30

Bonjour,

J'ai finalement choisi la solution "formule"

Tout ce que j'ai essayé autrement ralenti trop le fonctionnement de mon fichier

Merci de votre aide à tous, cela m'aura permis de progresser à différents niveaux.

Si ça intéresse quelqu'un : voici la formule qui fait le job :

Elle se base sur l'analyse du nombre de caractère + 1 discriminant, ce qui donne les caractères à extraire :

1ere ligne :

Pour l'affichage "-1h" : Si 3 caractères ET "h", alors on extrait 1 caractère à partir de la position 2, et on divise par 24

3 et h -1h 2;1 /24

3 et d -1d 2;1 /1

3 -1w 2;1 *7

4 -10h 2;2 /24

5 -5min 2;1 /24 /60

6 et min -15min 2;2 /24 /60

6 et m -8h 4m 2;1 /24 + 5;1 /24 /60

6 et w -1w 4d 2;1 *7 + 5;1 *1

6 -1d 3h 2;1 *1 + 5;1 /24

7 et d -1d 29h 2;1 *1 + 5;2 /24

7 et " " en 5eme -12h 8m 2;2 /24 + 6;1 /24 /60

7 -3h 17m 2;1 /24 + 5;2 /24 /60

8 -15h 59m 2;2 /24 + 6;2 /24 /60

=SI(GAUCHE(J18;1)="-";SI(NBCAR(J18)=3;SI(NON(ESTERREUR(CHERCHE("h";J18)));STXT(J18;2;1)/24;SI(NON(ESTERREUR(CHERCHE("d";J18)));STXT(J18;2;1)/1;STXT(J18;2;1)*7));SI(NBCAR(J18)=4;STXT(J18;2;2)/24;SI(NBCAR(J18)=5;STXT(J18;2;1)/24/60;SI(NBCAR(J18)=6;SI(NON(ESTERREUR(CHERCHE("min";J18)));STXT(J18;2;2)/24/60;SI(NON(ESTERREUR(CHERCHE("m";J18)));(STXT(J18;2;1)/24)+STXT(J18;5;1)/24/60;SI(NON(ESTERREUR(CHERCHE("w";J18)));(STXT(J18;2;1)*7)+STXT(J18;5;1)*1;(STXT(J18;2;1)*1)+STXT(J18;5;1)/24)));SI(NBCAR(J18)=7;SI(NON(ESTERREUR(CHERCHE("d";J18)));(STXT(J18;2;1)*1)+STXT(J18;5;2)/24;SI(SIERREUR(CHERCHE(" ";J18);"")=5;(STXT(J18;2;2)/24)+STXT(J18;6;1)/24/60;(STXT(J18;2;1)/24)+STXT(J18;5;2)/24/60));(STXT(J18;2;2)/24)+STXT(J18;6;2)/24/60)))));"")

Rechercher des sujets similaires à "optimisation fonction vba"