Compter nombre de cellule carateres identiques

[oliviermuch]

Bonjour, voila je souhaite faire une macro, qui me permet de compter le nombre de fois qu'apparait chaque suite de caratere differente dans une colonne... J'ai mis un fichier d'exemple tres tres epuré pour que vous me compreniez mieux!
merci par avance a ceux et celles qui prendront le temps de m'aider.

Olivier

 

[oliviermuch]

Re : Compter nombre de cellule carateres identiques

Cijoint.fr - Service gratuit de dépôt de fichiers

je n'avais pas envoyé le bon.

Merci

 

[job75]

Re : Compter nombre de cellule carateres identiques

Bonjour oliviermuch, le forum,

Le problème venait de cette ligne :

For Each cel In .Range(.[w2], .[w65536].End(xlUp))

En effet la cellule W65536 est maintenant occuppée et .[w65536].End(xlUp) donne alors W2 (qui contient le texte vide "").

J'ai donc remplacé cette ligne par :

For Each cel In .[w2:w65536]

Cijoint.fr - Service gratuit de dépôt de fichiers

Concernant le temps de calcul sur mon ordi (2 Ghz), la 1ère boucle (détermination des items de d) dure 5 secondes, et la 2ème boucle 31 secondes.

En effet le calcul de Application.CountIf(.[w:w], cel) est un peu long sur 65536 lignes...

A+

 

[oliviermuch]

Re : Compter nombre de cellule carateres identiques

ok , tout est parfais pour moi, je vais pouvoir inclure cette macro dans mon fichier initial et finir ce fichier.
Le temps de reponse est excellent pour moi, parce que j'avais reussi a configurer excel sans macro, mais ca prennait 40 minutes de calcul pour arriver presque a la meme chose. C'est evident que le gain en vitesse est enorme.J'ai aussi un 2Gh.
Juste une dernière question constructive:si Application.CountIf(.[w:w], cel) ralenti le calcul . Si je demande a ma macro de faire une liste en colonne X des items sans les blancs, cela va t'il ralentir ou accélérer le processus ?
MERCI ENORMEMENT JOB75.

Olivier

 

[job75]

Re : Compter nombre de cellule carateres identiques

Re,

Le nombre de blancs (du texte vide "" en fait) sur la plage W2:W65536 est de 28122.

Si ces blancs étaient supprimés, on devrait a priori pouvoir réduire le temps de calcul (sur les 5 feuilles) de 28122/65535 = 42,9%, donc de 36 x 42,9% = 15 secondes.

Par contre il faut rajouter le temps nécessaire à la création des 5 listes en colonnes X.

Je regarde ça.

A+

 

[job75]

Re : Compter nombre de cellule carateres identiques

Re,

Avec cette macro modifiée (en rouge), le temps total de calcul est réduit de 9 secondes, soit 25%. Ce n'est pas négligeable.

L'établissement des 5 listes colonnes X prend en effet 6 secondes.

Sub Comptage()
Dim d As Object, ws As Worksheet, [COLOR="Red"]derlig(5), [/COLOR]cel As Range, n As Variant
[E3:K65536].ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
  With ws
    If .Index < 6 Then
[COLOR="Red"]      .[X2:X65536].Value = .[W2:W65536].Value
      .[X2:X65536].Sort Key1:=.[X2], Order1:=xlDescending, Header:=xlNo
      derlig(.Index) = Application.CountA(.[X2:X65536]) + 1
      For Each cel In .Range("X2:X" & derlig(.Index))
 [/COLOR]       If Not d.Exists(cel.Value) Then d.Add cel.Value, CStr(cel.Value)
      Next
    End If
  End With
Next
[E3].Resize(d.Count) = Application.Transpose(d.items)
For Each cel In Range([E3], [E65536].End(xlUp))
  For Each ws In Worksheets
    With ws
      If .Index < 6 Then
        n = Application.CountIf(.[COLOR="Red"]Range("X2:X" & derlig(.Index))[/COLOR], cel)
        cel.Offset(, 1) = n + cel.Offset(, 1)
        cel.Offset(, .Index + 1) = n
      End If
    End With
  Next
Next
[E3:K65536].Sort Key1:=[F3], Order1:=xlDescending, Header:=xlNo
n = Application.Match([C3], [F:F], -1)
If IsError(n) Then n = 2
Range("E" & n + 1, [K65536]).ClearContents
End Sub

Le fichier :

Cijoint.fr - Service gratuit de dépôt de fichiers


Edition : supprimé le test And cel <> "" (inutile maintenant), cela fait gagner encore 1 seconde

Bonne fin de soirée.

 

[job75]

Re : Compter nombre de cellule carateres identiques

Bonjour oliviermuch,

Une imprécision corrigée à la fin de la macro.

Pour un Total de 10, on n'obtenait qu'une ligne dans le tableau, alors qu'il doit y en avoir 56 :

Sub Comptage()
Dim d As Object, ws As Worksheet, derlig(5), cel As Range, n As Variant
[E3:K65536].ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
  With ws
    If .Index < 6 Then
      .[X2:X65536].Value = .[W2:W65536].Value
      .[X2:X65536].Sort Key1:=.[X2], Order1:=xlDescending, Header:=xlNo
      derlig(.Index) = Application.CountA(.[X2:X65536]) + 1
      For Each cel In .Range("X2:X" & derlig(.Index))
        If Not d.Exists(cel.Value) Then d.Add cel.Value, CStr(cel.Value)
      Next
    End If
  End With
Next
[E3].Resize(d.Count) = Application.Transpose(d.items)
For Each cel In Range([E3], [E65536].End(xlUp))
  For Each ws In Worksheets
    With ws
      If .Index < 6 Then
        n = Application.CountIf(.Range("X2:X" & derlig(.Index)), cel)
        cel.Offset(, 1) = n + cel.Offset(, 1)
        cel.Offset(, .Index + 1) = n
      End If
    End With
  Next
Next
[E3:K65536].Sort Key1:=[F3], Order1:=xlDescending, Header:=xlNo
n = Application.Match([COLOR="Red"]Int([C3]) - 0.5[/COLOR], [F:F], -1)
If IsError(n) Then n = 2
Range("E" & n + 1, [K65536]).ClearContents
End Sub

Le fichier :

Cijoint.fr - Service gratuit de dépôt de fichiers

A+

 

[oliviermuch]

Re : Compter nombre de cellule carateres identiques

Tout est beau pour moi, ca prends environ 25 secondes dans la version originale avec les 5 feuilles différentes.

Je vais certainement avoir d'autres questions dans un futur très très proches toujours au sujet de ce fichier, car il est developpé a 25%.

Enocre une fois Merci Job75.