[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 ...
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).
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