Comment accélérer une boucle ?

[nak]

Bonjour le forum,

J'avais déjà demandé de l'aide pour importer un grand nombre de données le plus rapidement possible. Le poste avez eu un énorme succès. J'espère qu'il en sera de même aujourd'hui.

Je veux réaliser un truc tout simple. Pour chaque cellule de ma colonne "A", je veux compter le nombre de fois que la valeur apparait dans la colonne.
Je suis parti sur un code avec deux boucles. Je compare A1 avec A2:Ax et j'incrémente B1, en suite je passe en A2 pour faire la même chose, A3 etc...
Malheureusement ces deux boucles sont trop longues à s'exécuter (76000 secondes sur mon processeur i7 ).

Voici le détail :

Sub compter()
Application.ScreenUpdating = False
Sheets("Feuil1").Columns("B:B").ClearContents
x = Timer
'Compter les cellules identiques
ligne = Sheets("Feuil1").Range("A1000000").End(xlUp).Row
    NbCodes = 0
    For i = 1 To ligne
    doc = Sheets("Feuil1").Cells(i, 1).Value
        For j = 2 To ligne
            If Sheets("Feuil1").Cells(j, 1).Value = doc Then NbCodes = NbCodes + 1
        Next j
    Sheets("Feuil1").Cells(i, 2).Value = NbCodes
    NbCodes = 0
    Next i
Application.ScreenUpdating = True
MsgBox x
End Sub

Avez vous une solution plus rapide pour le même résultat ?

Je vous joins le petit fichier.

Merci

A+

 

[Misange]

Re : Comment accélérer une boucle ?

Bonjour

pourquoi passer par une macro ?
En mettant la première colonne sous forme de tableau (histoire que ce soit dynamique si tu ajoutes des valeurs ensuite).
(ça décale tes cellules d'une ligne vers le bas car il faut ajouter un titre de colonne)

en B2 : =NB.SI(Tableau2[Colonne1];Tableau2[@Colonne1])
c'est immédiat

Sinon, de façon à avoir en sortie un tableau avec la liste des différentes valeurs et le nombre de fois qu'elles apparaissent : un tableau croisé dynamique deux clics et c'est fait

 

[CHALET53]

Re : Comment accélérer une boucle ?

bonsoir,

Si tu tries ta colonne : tu as tous les AA à suivre et ainsi de suite
tu peux faire ton comptage en une fraction de seconde

 

[nak]

Re : Comment accélérer une boucle ?

Bonsoir,

@Misange, tout simplement parce que cela représente juste un bout de code de la macro finale...

@Chalet, ok pour faire le tri mais après comment compter très vite pour mettre le résultat en colonne B ?

Merci

 

[Habitude]

Re : Comment accélérer une boucle ?

Bonjour

D'abord, évite de recompter une valeur déjà compté te ferais gagné beaucoup de temps.

 

[Misange]

Re : Comment accélérer une boucle ?

Bonsoir,

@Misange, tout simplement parce que cela représente juste un bout de code de la macro finale...

Merci

Mais comme ta macro ne fait que mettre dans la colonne d'à côté un résultat que tu peux obtenir en une fraction de seconde avec une formule, (contre plusieurs dizaines avec ta macro...) il est autrement plus efficace de faire un tableau et de mettre la formule à côté (avec un tableau elle s'étend toute seule quand tu ajoutes des données.

 

[nak]

Re : Comment accélérer une boucle ?

Je suis arrivé à gagner pas mal de temps avec cette fonction :

Sub compter2()
Application.ScreenUpdating = False
Sheets("Feuil1").Columns("C:C").ClearContents
x = Timer
ligne = Sheets("Feuil1").Range("A1000000").End(xlUp).Row
For i = 1 To ligne
Sheets("Feuil1").Cells(i, 3).Value = WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1).Value)
Next i
Application.ScreenUpdating = True
MsgBox Timer - x
End Sub

De 27 secondes à 0.57 secondes

Si j'optimise encore je peux encore gagner. Je vais rajouter des lignes pour le chalenge.

Si vous avez d'autres conseils...

Merci

 

[klin89]

Re : Comment accélérer une boucle ?

Bonsoir nak,
Bonsoir à tous,

Un petit tour sur le site de Jacques Boisgontier s'impose pour découvrir l'objet Dictionary

Sub Doublons()
Set mondico = CreateObject("Scripting.Dictionary")
Set Plg = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each c In Plg
  mondico(c.Value) = mondico(c.Value) + 1
Next c
Range("C1").Resize(mondico.Count, 1) = Application.Transpose(mondico.keys) 'Clé
Range("D1").Resize(mondico.Count, 1) = Application.Transpose(mondico.items) 'Nbre d'items
End Sub

Klin89

 

[Robert]

Re : Comment accélérer une boucle ?

Bonsoir le fil, bonsoir le forum,

Moi qui d'habitude n'aime pas faire la course... Me voilà servi !
Avec la méthode que j'appelle "Jacques BOISGONTIER" (parce que c'est sur son site que je l'ai apprise) ça donne, chez moi, 0.234375 pour 65300 lignes...
Le code :

Sub compter2()
Dim dl As Long
Dim tb As Variant

Application.ScreenUpdating = False
Sheets("Feuil1").Columns("C:D").ClearContents
Set d = CreateObject("Scripting.Dictionary")
x = Timer
With Sheets("Feuil1")
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    tb = .Range("A1:A" & dl)
    For i = LBound(tb) To UBound(tb)
        d(tb(i, 1)) = d(tb(i, 1)) + 1
    Next i
    .Range("C1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.keys)
    .Range("D1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.items)
End With
Application.ScreenUpdating = True
MsgBox Timer - x
End Sub

Le fichier :

[Édition]
Bonsoir Klin on s'est croisé...

 

[Lone-wolf]

Re : Comment accélérer une boucle ?

Bonjour Misange, Chalet53, Habitude, nak

@ nak : essaie ce code sans trier la colonne. Temps : 0.015625

  Sub Somme_Doublons()
Dim i As Long, plage As Range
    Set plage = Range("a1:a1997")
x = Timer

For i = 1 To 7
With Application.WorksheetFunction
If .CountIf(plage, Cells(i, 1)) > 1 Then _
    Cells(i, 3) = .CountIf(plage, Cells(i, 1))
   End With
Next i
MsgBox Timer - x
End Sub

A+

 

[laetitia90]

Re : Comment accélérer une boucle ?

bonjour tous
une autre facon de l'ecrire mais oblige d'activer la reference microsoft scripting runtime

Sub es()
 Dim t(), i As Long, m As Dictionary, s As Long
  s = Timer
  Set m = New Dictionary
  t = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
  For i = 1 To UBound(t)
  m(t(i, 1)) = m(t(i, 1)) + 1
  Next i
  [c1].Resize(m.Count) = Application.Transpose(m.keys)
  [d1].Resize(m.Count) = Application.Transpose(m.Items)
  MsgBox Timer - s
End Sub

ps Robert Application.WorksheetFunction.Transpose sert a rien dans ce cas

autrement on peut activer la reference par code

Sub runtime()
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\scrrun.dll"
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub

 

[Lone-wolf]

Re : Comment accélérer une boucle ?

Bonjour à tous

Une variante du code que j'ai proposé. Pour 41500 lignes 0.20...

Sub Somme_Doublons()
Dim i As Long, plage As Range, fonction As WorksheetFunction
    Set plage = Range("a1:a41501")
    Set fonction = Application.WorksheetFunction

x = Timer

For i = 1 To 7
If fonction.CountIf(plage, Cells(i, 1)) > 1 Then _
    Cells(i, 3) = fonction.CountIf(plage, Cells(i, 1))
Next i
MsgBox Timer - x
End Sub

A+

 

[Lone-wolf]

Re : Comment accélérer une boucle ?

Rebonjour


@ laetitia : Bravo laetitia, tu es la plus rapide!!.

Note: j'aimerais bien te rattrapper... mais tu cours trop vite!!


A+

 

[nak]

Re : Comment accélérer une boucle ?

Bonjour à tous,

Il y a pas à dire vous avez de sacrés méthodes, beaucoup plus rapide que moi en tout cas !
Je n'ai pas encore fait mon choix. Merci à tous !

Je me permet de rajouter un code différent. Il me permet d’effacer des lignes sous conditions. Le voici :

Sub supprimerlignevideliste()
Dim i As Integer
For i = Sheets("Feuil2").Range("U65536").End(xlUp).Row To 2 Step -1
        If Sheets("Feuil2").Cells(i, 24) = "" And Sheets("Feuil2").Cells(i, 25) = "" And _
        Sheets("Feuil2").Cells(i, 26) = "" And Sheets("Feuil2").Cells(i, 27) = "" Then
           Sheets("Feuil2").Rows(i).Delete
        End If
Next i
End Sub

Évidement cette version n'avance pas...
Je suis donc aller faire un tour sur le site de Jacques BOISGONTIER mais je n'arrive pas à adapter le code proposé.

Sub supLignesRapide() 
          Application.ScreenUpdating = False
          Columns("b:b").Insert Shift:=xlToRight
          Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1          = "=IF(RC[-1]=""xxxx"",""sup"",0)"
          [B:B].Value = [B:B].Value
          [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending,          Header:=xlGuess
          On Error Resume Next
          Range("B2:B65000").SpecialCells(xlCellTypeConstants,          2).EntireRow.Delete
          Columns("b:b").Delete Shift:=xlToLeft
        End Sub

Pouvez vous me l'expliquer en détails SVP ?

Merci

A+

 

[BOISGONTIER]

Re : Comment accélérer une boucle ?

Bonsoir,


On regroupe les lignes à supprimer en fin de tableau.
La suppression des lignes ainsi regroupées en fin de tableau est très rapide.
L'ordre initial des lignes n'est pas modifié.

-on repère les lignes à supprimer avec la valeur Sup
-on tri les lignes . Les lignes contenant Sup se retrouvent à la fin
-on supprime les lignes contenant Sup

Sub supLignesRapide()
  Application.ScreenUpdating = False
  Columns("V:V").Insert Shift:=xlToRight
  Range("V2:V" & [U65000].End(xlUp).Row).FormulaR1C1 = "=IF(and(RC[3]="""",RC[4]="""",RC[5]="""",RC[6]="""" ) ,""sup"",0)"
  [V:V].Value = [V:V].Value
  [U2].CurrentRegion.Sort Key1:=Range("v2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("V2:V65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("V:V").Delete Shift:=xlToLeft
End Sub

JB