XL 2010 Accélérer vba excel 2007

  • Initiateur de la discussion Initiateur de la discussion chilo27
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

chilo27

XLDnaute Occasionnel
Bonsoir le forum

Je souhaite accélérer le décompte, mais je bug

je vous remercie chaleureusement pour votre aide
je joins un petit fichier
Merci par avance
 

Pièces jointes

Solution
Donc si votre version Excel n'aime pas Application.Index utilisez ce fichier (2) avec :
Code:
Sub Decompte()
Dim d As Object, j%, tablo, ub&, resu%(), i&, n%
Set d = CreateObject("Scripting.Dictionary")
For j = 2 To 6: d(Cells(4, j).Value) = "": Next j 'liste sans doublon
With Range("A6", Range("F" & Rows.Count).End(xlUp)).Resize(, 6)
    If .Row < 6 Then Exit Sub
    tablo = .Value 'matrice, plus rapide
    ub = UBound(tablo)
    ReDim resu(1 To ub, 1 To 1)
    For i = 1 To ub
        n = 0
        For j = 1 To 6
            If d.exists(tablo(i, j)) Then n = n + 1
        Next j
        resu(i, 1) = n
    Next i
    '---restitution---
    .Columns(1) = resu
    .Rows(1).Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en...
Bonjour Chilo, Patrick,
Sinon si vous tenez au VBA pour d'autres raisons, une seule règle.
Si on veut aller vite il est "interdit" d'accéder aux cellules. C'est ce qui prends le plus de temps.
Il faut donc passer par des arrays.
La macro ci dessous prends 0.3s sur mon PC.
VB:
Sub Decompte()
T0 = Timer
Dim T(), Nbres(), Result()
Range("A5:A55000").ClearContents
ReDim T(55994, 4), Result(55994)
Nbres = Range("B4:F4")
For i = 0 To 55994
   For j = 0 To 4
      For k = 1 To 5
      If T(i, j) = Nbres(1, k) Then N = N + 1
      Next k
   Next j
Result(i) = N: N = 0
Next i
Cells(6, 1).Resize(UBound(Result)) = Application.Transpose(Result)
If Application.CountIf(Range("A6:A55000"), 5) > 0 Then Range("A5") = "trouvé"
MsgBox Timer - T0
End Sub
Par contre, vérifiez, c'est du transfert brut, je n'ai pas cherché à fignoler.
PS: Pour vérifier l'écart de vitesse entre accès cellules et accès array, une petite démo qui donne un ordre d'idée.
 

Pièces jointes

Bonsoir le forum, mer patricktoulon

je suis confus j'ai oublié de donner plus de précision

Je souhaitais afficher dans la colonne A, le nombre de fois qu'apparait les nombres dans B4 a f4 dans n'importe quel ordre
Merci donc de vous pencher sur fichier et le code VBA

Désolé, et merci de vous pencher sur mon problème
 
Bonsoir

Oui tout a fait afficher dans la colonne A le nombre de fois qu'apparait la ligne B4:F4
dans n'importe quel ordre le fichier contient un bout de code et s'il était possible de lui donner un petit coup d'accélérateur

Merci par avance pour le coup de main
 
Re,
En PJ un essai à la fois rapide et qui détecte même dans le désordre.
Pour aller plus vite, je m'arrête dès qu'une combinaison est trouvée.
Sur mon PC 0.32s pour trouver la combinaison dans le désordre en A65000.
Code:
Sub Decompte()
T0 = Timer
Dim T(), Nbres(), Result()
[A5] = ""
ReDim T(65500, 4), Result(55994)
Nbres = Range("B4:F4")
T = Range("B5:F65000")
For i = 1 To 65000
    N = 0
    For j = 1 To 5
        For k = 1 To 5
            If T(i, j) = Nbres(1, k) Then N = N + 1
        Next k
        If N = 5 Then
            Cells(5, 1) = "Trouvé en ligne " & i + 4
            GoTo Fin
        End If
   Next j
Next i
Exit Sub
Fin:
MsgBox "Temps execution : " & Timer - T0 & "s."
End Sub
 

Pièces jointes

Bonsoir chilo27, patricktoulon, sylvanu,

S'agissant d'une comparaison dans n'importe quel ordre, pour aller vite il faut utiliser le Dictionary :
VB:
Sub Decompte()
Dim d As Object, j%, tablo, ub&, i&, n%
Set d = CreateObject("Scripting.Dictionary")
For j = 2 To 6: d(Cells(4, j).Value) = "": Next j 'liste sans doublon
With Range("A6", Range("F" & Rows.Count).End(xlUp)).Resize(, 6)
    If .Row < 6 Then Exit Sub
    tablo = .Value 'matrice, plus rapide
    ub = UBound(tablo)
    For i = 1 To ub
        n = 0
        For j = 2 To 6
            If d.exists(tablo(i, j)) Then n = n + 1
        Next j
        tablo(i, 1) = n
    Next i
    '---restitution---
    .Columns(1) = Application.Index(tablo, 0, 1)
    ..Rows(1).Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub
A+
 

Pièces jointes

Dernière édition:
Bonsoir chilo27, patricktoulon, sylvanu,

S'agissant d'une comparaison dans n'importe quel ordre, pour aller vite il faut utiliser le Dictionary :
VB:
Sub Decompte()
Dim d As Object, j%, tablo, ub&, i&, n%
Set d = CreateObject("Scripting.Dictionary")
For j = 2 To 6: d(Cells(4, j).Value) = "": Next j 'liste sans doublon
With Range("A6", Range("F" & Rows.Count).End(xlUp)).Resize(, 6)
    If .Row < 6 Then Exit Sub
    tablo = .Value 'matrice, plus rapide
    ub = UBound(tablo)
    For i = 1 To ub
        n = 0
        For j = 2 To 6
            If d.exists(tablo(i, j)) Then n = n + 1
        Next j
        tablo(i, 1) = n
    Next i
    '---restitution---
    .Columns(1) = Application.Index(tablo, 0, 1)
    .Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub
A+
Rebonsoir, Bonsoir Job75

C'est exactement cela, le seul petit regret pas de message trouvé
Mais je me satisfait du résultat

Merci Beaucoup
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
6
Affichages
152
Réponses
3
Affichages
136
Réponses
5
Affichages
275
  • Résolu(e)
Microsoft 365 transposer
Réponses
6
Affichages
146
Réponses
7
Affichages
151
Réponses
5
Affichages
111
Réponses
4
Affichages
129
Deleted member 453598
D
Retour