[VBA] Vitesse exec code - compter dans un tableau

Bonjour,

Il y a en effet quelques optimisations, comme changer ceci

en ceci

If .Cells(i, co) = "" Or .Cells(i, co) = "Code erroné" Then

Eriiic l'avait signalé !

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

mais 95% du temps est bien consommé par ces instructions WorksheetFunction.CountIfs

For i = 2 To UBound(aa)
    If cc(i, 1) = "" Or cc(i, 1) = "Code erroné" Then
        nnc = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnc), bd.Cells(lrbd, cnc)), aa(i, 1)) 'bd.Range(bd.Cells(2, cnc), bd.Cells(lrbd, cnc))
        nnv = WorksheetFunction.CountIfs(bd.Range(bd.Cells(2, cnv), bd.Cells(lrbd, cnv)), aa(i, 1)) 'bd.Range(bd.Cells(2, cnv), bd.Cells(lrbd, cnv))
    End If
Debug.Print i, nnv, nnc, Format(Now - temps, "hh:mm:ss")
Next i

j'ai élagué petit à petit tout le reste.

En soi, l'instruction n'est pas très longue ~1 secondes, mais elle est répétée.

Il faut donc trouver un moyen de ne la faire qu'une seule fois.

  • Soit avec

    qui devrait renvoyer une matrice
  • soit peut-être via dico t un décompte
  • soit un TCD ...

en une seule fois !

à suivre

Un petit test fonctionnel avec Application.Match

Sub test()

    tout_mon_tableau = Range("A1").CurrentRegion.Value
    tous_mes_criteres = Range("I1").CurrentRegion.Value

    tt = Application.Match(tout_mon_tableau, tous_mes_criteres, 0)

    Debug.Print UBound(tt), UBound(tt, 2)
    For i = 1 To UBound(tt)
        For j = 1 To UBound(tt, 2)
            Debug.Print i, j, tout_mon_tableau(i, j), tt(i, j)
        Next
    Next

End Sub

J'ai un résultat en 6 secondes au lieu de 17, mais je ne pense pas qu'il soit bon !!

Peux-tu me dire ce que représentent nnc et nnv ? (en texte, pas de formule)

Bonsoir,

nnc = nombre de fois que le code recherché (dans Liste Flore) est trouvé dans la colonne Code_NC de la feuille "BASE DE DONNEES FLORE"

nnv = nombre de fois que le code recherché (dans Liste Flore) est trouvé dans la colonne Code_NV de la feuille "BASE DE DONNEES FLORE"

C'est avec chiffres que je détermine si le code est un code jumeau (codes identiques avec correspondance différente) ; un synonyme (code utilisé dans la colonne Code_NC, mais qui n'est plus valide (Code_NV)) ; code erroné (si 0 résultat) ; sinon la correspondance est recherchée.

Je n'ai pas encore pu tester vos solutions, j'ai un rapport à terminer ce soir en urgence ; mais je teste tout dès que possible !

A plus tard

En m'appuyant sur un TCD je met 7 s (totalité de la proc) sur un PC de 13 ans d'age.

L'actualisation des TCD en eux-même prend environ 4s. Mais je suppose que ce n'est à faire que de temps en temps.

        For i = 2 To UBound(aa)
            If .Cells(i, co) = "" Or .Cells(i, co) = "Code erroné" Then
                    Sheets("TCD").[G2] = aa(i, 1)
                    tmp = Sheets("TCD").Range("G4:H4")
                    nnc = tmp(1, 1)
                    nnv = tmp(1, 2)

il reste encore la possibilité de charger les TCD en mémoire pour supprimer les accès feuilles.

Par contre la taille double.

eric

Très intéressant eriiic !

De mon côté, j'ai exploité scripting.dictionary (qui n'est in fine que le reflet d'un TCD)

J'ajoute

Set Dict1 = CreateObject("scripting.dictionary")
Set d = CreateObject("Scripting.Dictionary")

'=========ajout=========
Set dnnc = CreateObject("Scripting.Dictionary")
Set dnnv = 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

    '=========ajout==========
    For a = LBound(tablo2) To UBound(tablo2)
        dnnc(tablo2(a, 1)) = dnnc(tablo2(a, 1)) + 1
    Next a
    For a = LBound(tablo2b) To UBound(tablo2b)
        dnnv(tablo2b(a, 1)) = dnnv(tablo2b(a, 1)) + 1
    Next a
    '========================

End With

et dans le code, je remplace

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

par

            nnc = IIf(dnnc.exists(aa(i, 1)), dnnc(aa(i, 1)), 0)
            nnv = IIf(dnnv.exists(aa(i, 1)), dnnv(aa(i, 1)), 0)

j'arrive à 3 secondes ...

capture d ecran 643

Bonsoir,

En passant par deux autres dictionnaires vous avez réussi à clairement réduire le temps d'exécution de la macro ! Merci beaucoup !

Je n'ai pas encore terminé de travailler sur la base de données, mais d'ici peu je vais faire en sorte de pouvoir sélectionner les listes de données avec lesquelles on veut travailler, via des options, du coup la création des dictionnaires devrait être plus rapide, car moins de lignes, et la recherche dans ces dictionnaire sera également facilitée.

Enfin, avec 3 secondes d'exécution de la macro, je ne suis plus à 1 seconde !

Merci beaucoup, je vais faire des tests avec plusieurs jeux de données et je reviens vers vous, si ça marche bien, ou pas.. Et avec la macro que j'ai légèrement modifié selon vos indications précédentes (ne plus vérifier si UserFrom.checkBox = True ou False "x" fois, ne pas vérifier les données dans la feuille mais dans le tableau).

A plus tard

Bonsoir,

J'ai bien mis à jour la base de données, optimisé le code selon vos indications précédentes.

Le tout s'exécute toujours en 3 secondes (parfois deux).

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

t = Now

Set Dict1 = CreateObject("scripting.dictionary"): Set Dict2 = CreateObject("scripting.dictionary")
Set d = CreateObject("Scripting.Dictionary")
Set dnnc = CreateObject("Scripting.Dictionary")
Set dnnv = 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, cnv), .Cells(lrbd, cnv))
    tablo2b = .Range(.Cells(2, cnc), .Cells(lrbd, cnc))
    For a = LBound(tablo1) To UBound(tablo1)
        Dict1(tablo2(a, 1)) = tablo1(a, 1)
        Dict2(tablo2b(a, 1)) = tablo1(a, 1)
    Next a

    For a = LBound(tablo2) To UBound(tablo2)
        dnnv(tablo2(a, 1)) = dnnv(tablo2(a, 1)) + 1: dnnc(tablo2b(a, 1)) = dnnc(tablo2b(a, 1)) + 1
    Next a
End With

With lf
    lrlf = .Cells(.Rows.Count, 3).End(xlUp).Row
    lclf = .Cells(1, .Columns.Count).End(xlToLeft).Column
    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

'Classer les données (A-Z)
.Range(.Cells(1, 1), .Cells(lrlf, lclf)).Sort Key1:=.Range(.Cells(2, es), .Cells(lrlf, es)), Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom

s = Sheets("Options").Cells(16, 1)
aa = .Range(.Cells(1, 1), .Cells(lrlf, lclf))
y = 1
ReDim bb(1 To 1, 1 To y)
    For i = 2 To UBound(aa)
    If aa(i, co) <> "" And aa(i, co) <> "Code erroné" Then
        ReDim Preserve bb(1 To 1, 1 To y): bb(1, y) = aa(i, co): y = y + 1: GoTo 1
    Else
        If aa(i, es) = aa(i - 1, es) Then
            ReDim Preserve bb(1 To 1, 1 To y): bb(1, y) = bb(1, y - 1): y = y + 1
        Else
            nnv = IIf(dnnv.exists(aa(i, es)), dnnv(aa(i, es)), 0)
            nnc = IIf(dnnc.exists(aa(i, es)), dnnc(aa(i, es)), 0)
            If nnv = 0 And nnc = 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
            If nnv = 0 And nnc > 0 Then
                If s = 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) = "Synonymes": y = y + 1
                    End If
                End If
                If s = 1 Then
                    ReDim Preserve bb(1 To 1, 1 To y)
                    If Dict2.exists(aa(i, es)) Then bb(1, y) = Dict2(aa(i, es)): y = y + 1
                End If
            End If
            If nnv = 1 Then
                ReDim Preserve bb(1 To 1, 1 To y)
                If Dict1.exists(aa(i, es)) Then bb(1, y) = Dict1(aa(i, es)): y = y + 1
            End If
            If nnv > 1 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
        End If
    End If
1   Next i
    .Cells(2, co).Resize(lrlf - 1, 1) = Application.Transpose(bb)
End With
Set aa = Nothing: Set bb = Nothing

MsgBox "Fin en " & Format(Now - t, "hh:mm:ss")

End Sub

Difficile de faire mieux ! Vous m'avez encore beaucoup aidé sur ce problème là ! Merci beaucoup

La procédure dans sa totalité s'exécute en environ 6 secondes, c'est merveilleux vu la quantité de macros qui sont lancées !

Bonne soirée !

A plus tard

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