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