[VBA] Vitesse exec code - compter dans un tableau

Bonsoir,

Je peaufine depuis des mois les outils qui me servent très souvent, pour qu'ils correspondent au mieux à ce que j'essaie d'obtenir.

J'ai pu, souvent grâce à l'aide du forum, améliorer la vitesse d'exécution de mes codes ; et aujourd'hui, le groupe de macros que j'exécute termine son travail en 22 secondes, c'est 2 secondes de mieux qu'hier, mais l'une des macros utilise, à elle seule, 20 secondes. Si je parviens à bien mettre à jour cette dernière, le tout pourrait s'exécuter très vite !

Fonctionnement de la macro :

  • liste de codes dans la colonne C de la feuille "LISTE_FLORE"
  • chaque élément de cette liste est recherché dans la colonne "CODES_NC" ou "CODES_NV"
  • si 1 seule correspondance, alors celle-ci est récupérée dans (colonne "NOM_VALIDE") et inscrite dans la colonne D de la feuille "LISTE_FLORE".
  • si + de correspondances alors d'autres résultats.

J'ai travaillé sur les correspondances, j'utilise un dictionnaire et des tableaux. Cette méthode est normalement la plus rapide.

Mon problème :

J'aimerais changer cette partie du code :

nnc = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnc), bd.Cells(lrbd, cnc)), aa(i, 1))
nnv = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnv), bd.Cells(lrbd, cnv)), aa(i, 1))

Car je suspecte cette partie d'être chronophage.

L'idée serait de pouvoir compter le nombre d'occurrences( aa(i,1)) ) dans "tablo2" et dans tablo2b.

Mais je ne sais pas comment compter dans un tableau, je crois même que ce n'est pas possible directement comme je l'imagine.

Pour le moment je joins le fichier complet, (4mo) via cjoint ; pour bien illustrer la vitesse d'exécution du code ; si besoin je pourrai joindre un fichier allégé.

Macro (avec mes différentes tentatives ; en vert) :

Dim lrlf&, lclf&, aa, bb, a&, i%, y%, d, es As Byte, re As Byte, co As Byte, gl As Byte, Dict1 As Object
Dim lrbd&, cnc As Byte, nv As Byte, tablo1, nnc&, nnv&, cnv As Byte
Dim n&

Set Dict1 = CreateObject("scripting.dictionary")
Set d = CreateObject("Scripting.Dictionary")
With bd
    lrbd = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    cnc = .Range("1:1").Find("CODES_NC", LookIn:=xlValues, lookat:=xlWhole).Column
    cnv = .Range("1:1").Find("CODES_NV", LookIn:=xlValues, lookat:=xlWhole).Column
    nv = .Range("1:1").Find("NOM_VALIDE", LookIn:=xlValues, lookat:=xlWhole).Column
        tablo1 = .Range(.Cells(2, nv), .Cells(lrbd, nv))
        tablo2 = .Range(.Cells(2, cnc), .Cells(lrbd, cnc))
        tablo2b = .Range(.Cells(2, cnv), .Cells(lrbd, cnv))
            For a = LBound(tablo1) To UBound(tablo1)
                Dict1(tablo2(a, 1)) = tablo1(a, 1)
            Next a
End With

With lf
    lrlf = .Cells(.Rows.Count, 1).End(xlUp).Row
    gl = .Range("1:1").Find("globalid", LookIn:=xlValues).Column
    es = .Range("1:1").Find("especes", LookIn:=xlValues, lookat:=xlWhole).Column
    On Error Resume Next
    co = .Range("1:1").Find("Correspondance", LookIn:=xlValues).Column
        If co = 0 Then MsgBox ("Opération interrompue, l'en-tête de la colonne ""Correspondance"" a été modifié"): chk12 = chk12 + 1: Exit Sub

aa = .Range(.Cells(1, es), .Cells(lrlf, es))
y = 1
ReDim bb(1 To 1, 1 To y)

    For i = 2 To UBound(aa)
    If .Cells(i, co) = "" Or .Cells(i, co) = "Code erroné" Then
        'nnc = WorksheetFunction.CountIfs(tablo2, aa(i, 1)) 'bd.Range(bd.Cells(2, cnc), bd.Cells(lrbd, cnc))
        'nnv = WorksheetFunction.CountIfs(tablo2b, aa(i, 1)) 'bd.Range(bd.Cells(2, cnv), bd.Cells(lrbd, cnv))
'        nnc = 0
'        For n = 0 To UBound(tablo2)
'            If tablo2(n) = aa(i, 1) Then nnc = nnc + 1: If nnc > 2 Then Exit For
'        Next n
'        nnv = 0
'        For n = 0 To UBound(tablo2b)
'            If tablo2b(n) = aa(i, 1) Then nnv = nnv + 1: If nnv > 2 Then Exit For
'        Next n

'nnc = arrayCount(tablo2, aa(i, 1))
'nnv = arrayCount(tablo2b, aa(i, 1))

            If nnc = 0 Then
                If nnv = 0 Then
                    If Not d.exists(aa(i, gl)) Then
                        d.Add (aa(i, gl)), aa(i, gl)
                        ReDim Preserve bb(1 To 1, 1 To y)
                        bb(1, y) = "Code erroné": y = y + 1
                    End If
                End If
            End If
            If nnc >= 2 Then
                    If Not d.exists(aa(i, gl)) Then
                        d.Add (aa(i, gl)), aa(i, gl)
                        ReDim Preserve bb(1 To 1, 1 To y)
                        bb(1, y) = "Codes jumeaux": y = y + 1
                    End If
            End If
            If nnc = 1 Then
                If nnv = 0 Then
                    If UserForm_options.CheckBox12 = False Then
                        If Not d.exists(aa(i, gl)) Then
                            d.Add (aa(i, gl)), aa(i, gl)
                            ReDim Preserve bb(1 To 1, 1 To y)
                            bb(1, y) = "Synonymes": y = y + 1
                        End If
                    End If
                    If UserForm_options.CheckBox12 = True Then
                        ReDim Preserve bb(1 To 1, 1 To y)
                        If Dict1.exists(aa(i, 1)) Then bb(1, y) = Dict1(aa(a, 1)): y = y + 1
                    End If
                ElseIf nnv > 0 Then
                    ReDim Preserve bb(1 To 1, 1 To y)
                    If Dict1.exists(aa(i, 1)) Then bb(1, y) = Dict1(aa(i, 1)): y = y + 1
                End If
            End If
    End If
    Next i
    .Cells(2, co).Resize(lrlf - 1, 1) = Application.Transpose(bb)
End With
Set aa = Nothing: Set bb = Nothing
End Sub

Avez-vous une idée ?

Bonne soirée !

Bonjour,

je pense qu'en effet travailler sur un fichier allégé en données et en code est plus approprié

Exemple simplifié ... après avoir défini ton tableau, tbl ici, tu comptes le nombre de fois où le nombre 55 est présent.

Sub test()

    MsgBox WorksheetFunction.CountIfs(Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row), 55)
'ou
    tbl = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    MsgBox Application.Count(Application.Match(tbl, Array(55), 0))

End Sub

On remplace WorksheetFunction.CountIfs(_______ par Application.Count(Application.Match_______ avec quelques aménagements.

5drosophile.xlsm (24.62 Ko)

Ce fichier test fait moins de 25ko. Tu ne pourras bientôt plus mettre de fichiers aussi lourds (>1mo) même en lien.

Bonjour,

Je vous remercie !

En utilisant cette méthode, la macro fonctionne en pas à pas, mais ne fonctionne pas si je lance la macro.

Je vais essayer de voir ce qui peut bien poser problème...

Edit :

En fait, ce code ne fonctionne pas dans mon cas, il donne systématiquement 0

nnc = Application.Count(Application.Match(tablo2, Array(aa(i, 1)), 0))
nnv = Application.Count(Application.Match(tablo2b, Array(aa(i, 1)), 0))

C'est au niveau de Application.Match(tablo2, Array(aa(i, 1)), 0) que ça pose problème.

Et en essayant comme ceci :

    Dim k As Variant, j As Variant
nnc = 0
        For Each k In tablo2 'Dict1.Keys
            If k = aa(i, 1) Then nnc = nnc + 1 'Dict1(k)
                If nnc > 2 Then Exit For
        Next k
nnv = 0
        For Each j In tablo2b 'Dict1.Keys
            If j = aa(i, 1) Then nnv = nnv + 1 'Dict1(j)
                If nnv > 2 Then Exit For
        Next j

La macro passe environ le même temps à s'exécuter.

Je ne sais pas s'il faut mettre Array(aa(i, 1) ce qui n'aurait pas réellement de sens car aa est déjà un array !

Le problème est que je n'ai pas trop le temps de télécharger ton appli et de comprendre le code et le but ! C'est pour cela qu'un exemple ciblé sur ce que tu veux faire avec un minimum d'explications des formules peut être intéressant !

J'ai fait un test en construisant un gros fichier de données.

WorksheetFunction.CountIfs(Range("A2:N" & Range("A" & Rows.Count).End(xlUp).Row), 55) + _
        WorksheetFunction.CountIfs(Range("A2:N" & Range("A" & Rows.Count).End(xlUp).Row), 44)

est quasi instantané.

Et paradoxalement

Application.Count(Application.Match(tbl, Array(55, 44), 0))

serait un poil plus long !!!

Donc ton problème de lenteur ne vient pas de là.

Voilà mon conseil

Mets ceci en début de macro

temps = Now

puis là où tu le souhaites (mais pas à l'intérieur d'une boucle)

Debug.Print Now - temps

et autant de fois que tu le souhaites, tu arriveras peut-être à déterminer la portion de code chronophage !

Bonjour,

Si j'adapte votre proposition comme ceci :

nnc = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnc), bd.Cells(lrbd, cnc)), aa(i, 1))
nnv = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnv), bd.Cells(lrbd, cnv)), aa(i, 1))

ou bien

nnc = WorksheetFunction.CountIfs(tablo2, aa(i, 1))
nnv = WorksheetFunction.CountIfs(tablo2b, aa(i, 1))

Alors ça ne fonctionne pas, Excel ne compte pas.

Sinon je n'ai jamais utilisé : Debug.Print Now - temps.

Je l'ai mis dans le code comme indiqué, mais il ne se passe rien.

Si ça ne vient pas de cette partie, alors ça vient de cette partie là du code :

    If nnc = 0 Then
                If nnv = 0 Then
                    If Not d.Exists(aa(i, gl)) Then
                        d.Add (aa(i, gl)), aa(i, gl)
                        ReDim Preserve bb(1 To 1, 1 To y)
                        bb(1, y) = "Code erroné": y = y + 1
                    End If
                End If
            End If
            If nnc >= 2 Then
                    If Not d.Exists(aa(i, gl)) Then
                        d.Add (aa(i, gl)), aa(i, gl)
                        ReDim Preserve bb(1 To 1, 1 To y)
                        bb(1, y) = "Codes jumeaux": y = y + 1
                    End If
            End If
            If nnc = 1 Then
                If nnv = 0 Then
                    If UserForm_options.CheckBox12 = False Then
                        If Not d.Exists(aa(i, gl)) Then
                            d.Add (aa(i, gl)), aa(i, gl)
                            ReDim Preserve bb(1 To 1, 1 To y)
                            bb(1, y) = "Synonymes": y = y + 1
                        End If
                    End If
                    If UserForm_options.CheckBox12 = True Then
                        ReDim Preserve bb(1 To 1, 1 To y)
                        If Dict1.Exists(aa(i, 1)) Then bb(1, y) = Dict1(aa(a, 1)): y = y + 1
                    End If
                ElseIf nnv > 0 Then
                    ReDim Preserve bb(1 To 1, 1 To y)
                    If Dict1.Exists(aa(i, 1)) Then bb(1, y) = Dict1(aa(i, 1)): y = y + 1
                End If
            End If
    End If
    Next i
    .Cells(2, co).Resize(lrlf - 1, 1) = Application.Transpose(bb)
    

On rempli un tableau en fonction des valeurs de nnc et nnv, puis on colle le tableau.

Edit :

Je viens de faire passer à 15 secondes l'exécution du code en changeant

UserForm_options.CheckBox12 = False

par

Sheets("Options").Cells(16, 1) = 2 Then

Car toutes les options qui sont utilisées sont enregistrées dans une feuille dédiée.

Ah je n'avais pas vu ton précédent message :

Je ne sais pas s'il faut mettre Array(aa(i, 1) ce qui n'aurait pas réellement de sens car aa est déjà un array !

Le problème est que je n'ai pas trop le temps de télécharger ton appli et de comprendre le code et le but ! C'est pour cela qu'un exemple ciblé sur ce que tu veux faire avec un minimum d'explications des formules peut être intéressant !

Je vais essayer de faire quelque chose de plus léger alors, avec des explications dans le code.

A plus tard !

Bonsoir,

Voici un document allégé, avec quelques modifications effectuées sur la macro.

J'ai notamment essayé de passer par une collection pour voir si ça avait un effet. Rien d'extraordinaire.

Je me dit que peut-être il faudrait passer par un filtre ?

A chaque fois qu'un code doit être recherché, la base de donnée est filtrée selon ce code et la recherche est faite parmi les quelques données qui restent.

Alors par contre, étant donné que j'ai allégé le document, la macro s'exécute instantanément. Il ne faut pas se fier à ce document pour la calculer.

Bonne soirée !

Bonjour à tous,

Le Drosophile, pour récupérer les uniques dans la feuille "BASE DE DONNEES FLORE", ceci ne suffit pas.

Dans une boucle :

If Not dico.exists(a(i, 24)) Then  'si unique
    dico(a(i, 24)) = a(i, 29)
Else ' sinon
    dico(a(i, 24)) = empty
End If

If Not dico.exists(a(i, 28)) Then  'si unique
    dico(a(i, 28)) = a(i, 29)
Else ' sinon
    dico(a(i, 28)) = empty
End If

Après tu ventiles les éléments du dictionnaire à l'aide de la méthode "exists" dans la colonne D de la feuille "LISTE_FLORE"

klin89

Sinon je n'ai jamais utilisé : Debug.Print Now - temps.

Je l'ai mis dans le code comme indiqué, mais il ne se passe rien.

Pour voir quelque chose, tu vas dans l'explorateur de macro, et tu affiches la fenêtre d'exécution (Ctrl+G).

Je pense qu'il faut d'abord comprendre le temps d'exécution de chaque phase de ta macro.

Bonsoir,

J'ai placé 4 Debug.Print Now - temps dans la macro, à 4 étapes qui précèdent des boucles.

Il me sort ça :

2,31481462833472E-05

2,31481462833472E-05

1,7361110803904E-04

1,7361110803904E-04

Très curieux comme résultat

@Klin89

Si j'ai bien compris, cette partie :

If Not dico.exists(a(i, 24)) Then  'si unique
    dico(a(i, 24)) = a(i, 29)
Else ' sinon
    dico(a(i, 24)) = empty
End If

If Not dico.exists(a(i, 28)) Then  'si unique
    dico(a(i, 28)) = a(i, 29)
Else ' sinon
    dico(a(i, 28)) = empty
End If

Remplacerait cette partie du code (en adaptant) :

With bd
    lrbd = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    cnc = .Range("1:1").Find("CODES_NC", LookIn:=xlValues, lookat:=xlWhole).Column
    cnv = .Range("1:1").Find("CODES_NV", LookIn:=xlValues, lookat:=xlWhole).Column
    nv = .Range("1:1").Find("NOM_VALIDE", LookIn:=xlValues, lookat:=xlWhole).Column
        tablo1 = .Range(.Cells(2, nv), .Cells(lrbd, nv))
        tablo2 = .Range(.Cells(2, cnc), .Cells(lrbd, cnc))
        tablo2b = .Range(.Cells(2, cnv), .Cells(lrbd, cnv))
            For a = LBound(tablo1) To UBound(tablo1)
                Dict1(tablo2(a, 1)) = tablo1(a, 1)
            Next a
End With

Bonne soirée !

Bonsoir,

J'ai placé 4 Debug.Print Now - temps dans la macro, à 4 étapes qui précèdent des boucles.

Il me sort ça :

2,31481462833472E-05

2,31481462833472E-05

1,7361110803904E-04

1,7361110803904E-04

Très curieux comme résultat

On aurait pu mettre le format de type hh:mm:ss mais parfois on y trouve 0 secondes.

Pas si curieux que cela, car cela fait respectivement :

00:00:02

00:00:02

00:00:15

00:00:15

avec cela tu es fixé sur quelle(s) partie(s) du code se concentre le temps d'exécution.

Bonsoir,

cela signifie que c'est cette partie du code qui prend le plus de temps à s'exécuter :

Dim k As Variant, j As Variant
    nnc = 0
        For Each k In tablo2 'Dict1.Keys
            If k = aa(i, 1) Then nnc = nnc + 1 'Dict1(k)
                If nnc > 2 Then Exit For
        Next k
    nnv = 0
        For Each j In tablo2b 'Dict1.Keys
            If j = aa(i, 1) Then nnv = nnv + 1 'Dict1(j)
                If nnv > 2 Then Exit For
        Next j

            If nnc = 0 Then
                If nnv = 0 Then
                    col.Add ("Code erroné")
                End If
            End If
            If nnc >= 2 Then
                col.Add ("Codes jumeaux")
            End If
            If nnc = 1 Then
                If nnv = 0 Then
                    If Sheets("Options").Cells(16, 1) = 2 Then
                       col.Add ("Synonymes")
                    End If
                    If Sheets("Options").Cells(16, 1) = 1 Then
                        If Dict1.Exists(aa(i, 1)) Then col.Add (Dict1(aa(i, 1)))
                    End If
                ElseIf nnv > 0 Then
                    If Dict1.Exists(aa(i, 1)) Then col.Add (Dict1(aa(i, 1))) 'bb(1, y) = Dict1(aa(i, 1)): y = y + 1
                End If
            End If
    End If
    Next i

Je vais voir si je peux l'améliorer, sur les If pour commencer, mais ensuite je ne vois pas trop. J'alimente une collection, et je boucle sur cette collection pour coller les résultats.

D'ailleurs je me demande s'il n'y a pas une solution plus simple, du genre :

 .Cells(2, co).Resize(lrlf - 1, 1) = "collection" 

Bonne soirée !

Pourquoi faire appel sans cesse à ceci :

Sheets("Options").Cells(16, 1)

une fois pour toutes en début de code et utiliser ensuite la valeur !

C'est cela qui prend du temps !

Bonsoir,

En effet, inutile de recherche la valeur de la cellule à chaque fois.

J'ai mis à jour le code comme ceci :

Spoiler
s = Sheets("Options").Cells(16, 1)
    For i = 2 To UBound(aa)
        If .Cells(i, co) = "" Or .Cells(i, co) = "Code erroné" Then
Dim k As Variant, j As Variant
    nnc = 0
        For Each k In tablo2
            If k = aa(i, 1) Then nnc = nnc + 1
                If nnc > 2 Then Exit For
        Next k
    nnv = 0
        For Each j In tablo2b
            If j = aa(i, 1) Then nnv = nnv + 1
                If nnv > 2 Then Exit For
        Next j

            If nnc = 0 And nnv = 0 Then col.Add ("Code erroné")
            If nnc >= 2 Then col.Add ("Codes jumeaux")
            If nnc = 1 And nnv = 0 Then
                    s = 2 Then col.Add ("Synonymes")
                    s = 1 Then
                            If Dict1.Exists(aa(i, 1)) Then col.Add (Dict1(aa(i, 1)))
                    End If
            End If
            If nnc = 1 And nnv > 0 Then
            End If
        End If
    Next i

Le temps d'exécution reste sensiblement le même.

1,15740767796524E-05 1,15740767796524E-05 2,43055561440997E-04 2,43055561440997E-04

Comment faites-vous pour convertir ces valeurs en secondes ?

Edit :

Si je met à jour la première partie de la macro comme ceci :

            For i = LBound(tablo1) To UBound(tablo1)
                If Not Dict1.exists(tablo2(i, 1)) Then
                    Dict1(tablo2(i, 1)) = tablo1(i, 1)
                Else
                    Dict1(tablo2(i, 1)) = Empty
                End If
                If Not Dict1.exists(tablo2(i, 1)) Then
                    Dict1(tablo2b(i, 1)) = tablo1(i, 1)
                Else
                    Dict1(tablo2b(i, 1)) = Empty
                End If
            Next i

Alors je n'ai plus de résultats. La macro ne trouve plus rien et le temps d'exécution est allongé de quelques secondes.

Bonne soirée !

Le temps d'exécution reste sensiblement le même.

1,15740767796524E-05 1,15740767796524E-05 2,43055561440997E-04 2,43055561440997E-04

Comment faites-vous pour convertir ces valeurs en secondes ?

tu les colles dans excel et tu changes le format en hh:mm:ss

00:00:01

00:00:01

00:00:21

00:00:21

Bon, laisse moi un jour ou deux, je vais regarder de près pour descendre en dessous de 5 secondes. Peux-tu me donner ta dernière version de macro ?

Bonjour,

J'ai fait beaucoup de tests hier soir et j'ai différentes versions, je vais essayer de centraliser tout en gardant la plus performante. J'aimerais aussi faire des tests sur la base de données en amont, pour réduire le nombre de lignes à traiter.

Si avec ça, le temps d'exécution de la macro est toujours trop long, je posterai mon document.

Dans le cas contraire, ça vous évitera de vous y pencher.

Bonne journée !

ok, à ta disposition si tu le souhaites

pour évaluer le temps, tu peux mettre quelque chose comme

debug.print format(now-temps,"hh:mm:ss")

à tester

Bonjour à tous,

je ne sais pas trop où tu en es avec ce code mais ici :

    For i = 2 To UBound(aa)
    If .Cells(i, co) = "" Or .Cells(i, co) = "Code erroné" Then

tu lis sur feuille et non dans un tableau, et 2 fois la même cellule de plus.

eric

Rechercher des sujets similaires à "vba vitesse exec code compter tableau"