Comptage uniquement si même ordre

[moteurV12]

Bonsoir Le Forum

J'aimerai que ce code analyse les données dans l'ordre exact au lieu de n'importe quel ordre comme c'est le cas actuellement.
Après de multiples essais, je me résous à faire appel à vous.

Sub Compte()
Dim Source As String, Col As Integer, t As Byte, Cel As Range, r As Integer

Range("EW1:EW" & Rows.Count).ClearContents

Sheets("Jeux").Select
For r = 12 To 79
For Col = 2 To 9
  Source = IIf(Col = 2, "*" & Cells(r, Col) & "*", Source & Cells(r, Col) & "*")
Next
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    
With Feuil19
  For Each Cel In .Range("A1:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
    t = 0
    For Col = 0 To 2
      If InStr(Source, "*" & Cel.Offset(0, Col).Value & "*") > 0 Then t = t + 1
    Next
    If t = 3 Then .Range("EW" & Cel.Row) = .Range("EW" & Cel.Row) + 1
  Next
End With
  Next r
  

    

    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub

 

[job75]

Re : Comptage uniquement si même ordre

Bonsoir moteurV12,

J'aimerai (...)

On copie un code et paf on le balance sans aucun fichier, aux bonnes pâtes de se débrouiller

A+

 

[moteurV12]

Re : Comptage uniquement si même ordre

Merci job75 d'exprimer votre avis, cela démontre que vous m'avez lu, ce qui est déjà pas si mal.

Pour être plus constructif, voici un fichier avec le code que j'utilise depuis un certains temps dans mon fichier original.


Les besoins évoluant et le fichier final étant déjà lourd en formules matricielles, j'essaie de remplacer petit à petit les formules par du code.

J'ai essayé toute cette semaine de modifier ce code ci afin de ne compter que les mêmes combinaisons de 3 chiffres dans l'ordre exact. ( le code fonctionne parfaitement si on compte dans n'importe quel ordre ).

Hélas je me débrouille en formules, mais pas terrible en code vba avancé.

 

[job75]

Re : Comptage uniquement si même ordre

Bonjour moteurV12, le forum,

Pour trouver les 3 premiers nombres dans l'ordre mémorisez leurs positions dans un tableau p :

Dim p(2)
'-----
With Feuil1
  For Each Cel In .[A:A].SpecialCells(xlCellTypeConstants)
    For Col = 0 To 2
      p(Col) = InStr(Source, "*" & Cel.Offset(0, Col) & "*")
    Next
    If p(0) And p(1) > p(0) And p(2) > p(1) Then _
      .Range("EW" & Cel.Row) = .Range("EW" & Cel.Row) + 1
  Next
End With

Bonne journée et A+

 

[job75]

Re : Comptage uniquement si même ordre

Re,

Autre solution, un peu plus rapide :

Dim mem%, p%
'-----
With Feuil1
  For Each Cel In .[A:A].SpecialCells(xlCellTypeConstants)
    mem = 0
    For Col = 1 To 3
      p = InStr(Source, "*" & Cel(, Col) & "*")
      If p > mem Then mem = p Else GoTo 1
    Next
    Cel(, "EW") = Cel(, "EW") + 1
1 Next
End With

A+

 

[job75]

Re : Comptage uniquement si même ordre

Re,

Avec des tableaux VBA l'exécution est nettement plus rapide :

Sub Compte()
Dim t1, t2, ub&, t(), i&, source$, j&, mem%, col As Byte, p%
t1 = Sheets("Jeux").[B11].CurrentRegion 'matrice, plus rapide
t2 = Feuil1.[A1].CurrentRegion 'matrice, plus rapide
ub = UBound(t2)
ReDim t(1 To ub, 1 To 1)
For i = 2 To UBound(t1)
  source = " " & Join(Application.Index(t1, i, 0)) & " "
  For j = 1 To ub
    mem = 0
    For col = 1 To 3
      p = InStr(source, " " & t2(j, col) & " ")
      If p > mem Then mem = p Else GoTo 1
    Next
    t(j, 1) = t(j, 1) + 1
1 Next
Next
'---restitution---
With Feuil1.[EW1]
  .Resize(ub) = t
  .Offset(ub).Resize(.Parent.Rows.Count - ub).ClearContents
End With
End Sub

Fichier joint.

A+

 

[job75]

Re : Comptage uniquement si même ordre

Re,

Les solutions précédentes, avec InStr, supposent que sur chaque ligne il n'y a pas de doublons.

Ce qui est le cas du fichier.

S'il pouvait y en avoir il faudrait alors utiliser :

Sub Compte()
Dim t1, t2, ub&, t(), i&, source$, j&, x$, col As Byte
t1 = Sheets("Jeux").[B11].CurrentRegion 'matrice, plus rapide
t2 = Feuil1.[A1].CurrentRegion 'matrice, plus rapide
ub = UBound(t2)
ReDim t(1 To ub, 1 To 1)
For i = 2 To UBound(t1)
  source = " " & Join(Application.Index(t1, i, 0), "  ") & " "
  For j = 1 To ub
    x = ""
    For col = 1 To 3
      x = x & t2(j, col) & " * "
    Next
    x = "* " & RTrim(x)
    If source Like x Then t(j, 1) = t(j, 1) + 1
  Next
Next
'---restitution---
With Feuil1.[EW1]
  .Resize(ub) = t
  .Offset(ub).Resize(.Parent.Rows.Count - ub).ClearContents
End With
End Sub

L'exécution est moins rapide.

Fichier joint.

A+

 

[moteurV12]

Re : Comptage uniquement si même ordre

Bonjour Job75,

Il ni à jamais de doublons.
La solution précédente est effectivement beaucoup plus rapide et fonctionne parfaitement.
Afin d'adaptation dans mon fichier final et compte tenu des colonnes adjacentes pleines, j'ai simplement du changer CurrentRegion.

Voilà un problème parmi tant d'autres de régler et je t'en suis vraiment très très reconnaissant .

Question sur XL2010 64 Bits

Je travaille sur une machine très puissante, sur 1 disque virtuel en mémoire et avec 32 GO de mémoire physique.

Mon fichier fonctionne très bien ( 12mo ) 3000 lignes et des formules matricielles quasiment de la colonne F à EZ sur les 3000 lignes.

Si je rajoute une colonne de calcul matriciel le fichier ce met en rideau avec une soi disant erreur de formule circulaire QUI N'EXISTE PAS.

Hors d'après la documentation krosoft la seule limitation est la mémoire. Je ne comprends donc pas pourquoi cette fausse erreur ce déclenche. Une idée sans voir le fichier ?????

 

[job75]

Re : Comptage uniquement si même ordre

Re,

J'avais mis des Application.Transpose inutiles, vérifiez que vous prenez bien la dernière macro au post #6.

Compte-tenu des nombreuses colonnes adjacentes en Feuil1, il suffit de limiter le tableau t2 :

t2 = Feuil1.[A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide

Enfin si Excel vous dit qu'il y a des références circulaires c'est qu'il y en a, vérifiez vos formules.

A+

 

[moteurV12]

Re : Comptage uniquement si même ordre

J'ai bien pris la bonne macro. MERCI