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...
Bonsoir JoB75, SylvanuBonsoir chilo27, patricktoulon, sylvanu,
S'agissant d'une comparaison dans n'importe quel ordre, pour aller vite il faut utiliser le Dictionary :
A+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
Pas du tout, le problème posé au post #1 est de compter en colonne A le nombre d'occurrences des valeurs B4:F4 de chaque ligne.Ce qui est fait dans le post #13.
Chez moi sur 600 000 lignes pas de bug sur cette ligne, c'est peut-être dû à la version Excel.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
.Rows(1).Offset(ub).Resize(Rows.Count - ub - .Row + 1).ClearContents 'RAZ en dessous
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
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
Effectivement l'utilisation de FolrmulaR1C1 au lieu de FormulaLocal est plus rapide. J'ai donc modifié le code de mon précédent message.sans FormulaLocal en formule classique sur mon PC