XL 2010 Accélérer vba excel 2007

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

  • decompte.zip
    18 KB · Affichages: 28
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...

chilo27

XLDnaute Occasionnel
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+
Bonsoir JoB75, Sylvanu
J'ai un message Incompatibilité" sur cette ligne .Columns(1) = Application.Index(tablo, 0, 1)
quand je dépasse ligne 65000
Je peux avoir au moins 600000 lignes à traiter

Mais autrement c'est rapide même si j'ai 65000 lignes

Merci
 

job75

XLDnaute Barbatruc
J'ai un message Incompatibilité" sur cette ligne .Columns(1) = Application.Index(tablo, 0, 1)
quand je dépasse ligne 65000
Je peux avoir au moins 600000 lignes à traiter
Chez moi sur 600 000 lignes pas de bug sur cette ligne, c'est peut-être dû à la version Excel.

Par contre sur la ligne suivante il y a bug.

Je corrige donc cette ligne dans mon post #9 avec :
VB:
.Rows(1).Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Pour le FUN. Une autre macro (si j'ai bien compris). Pas la plus rapide, mais relativement concise :
VB:
Sub DecompteMapommeRapide()
'utilisation de FormulaR1C1 au lieu FormulaLocal
Dim deb, der&
   deb = Timer: Application.ScreenUpdating = False
   Range(Range("a6"), Cells(Rows.Count, "a")).ClearContents
   der = Cells(Rows.Count, "b").End(xlUp).Row
   Range(Range("a6"), Cells(der, "a")).FormulaR1C1 = "=SUMPRODUCT(COUNTIF(R4C2:R4C6,RC[1]:RC[5]))"
   Range(Range("a6"), Cells(der, "a")) = Range(Range("a6"), Cells(der, "a")).Value
   MsgBox Format(Timer - deb, "0.00\ sec.")
End Sub

edit : modifié le code. Cette version est un peu plus rapide
 
Dernière édition:

job75

XLDnaute Barbatruc
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 dessous
End With
End Sub
Il faut un tableau VBA supplémentaire (resu).

Salut mapomme, je pense que SOMMEPROD avec NB.SI prendra bien plus de temps.
 

Pièces jointes

  • decompte(2).xlsm
    23.4 KB · Affichages: 11

chilo27

XLDnaute Occasionnel
Rebonjour le forum, Job75, Mapomme sans oublier les autres

Ce n'est pas de la flatterie, je ne sais pas faire mais
vos propositions sont top, là ou je mettais de longues minutes, l'opération s'effectue en quelques secondes.
Mon souci est le choix en Job75 et mapomme car seulement quelques secondes de différences entre les deux

Merci à vos deux pour l'aide
 

Discussions similaires

Réponses
6
Affichages
116

Statistiques des forums

Discussions
312 316
Messages
2 087 177
Membres
103 491
dernier inscrit
bilg1