Recherche dans une BD et tri d'une liste par fréquence

ivan27 · 31 Janvier 2015

Bonsoir à tous,

Je cherches à récupérer dans une liste les 20 noms les plus fréquents et/ou les plus récents à fréquence identiques.
Je n'arrive pas à adapter à mon cas le résultat de mes recherches sur le forum.
Merci d'avance pour votre aide.
Je vous communique un fichier explicatif.
Bien cordialement,

Ivan

job75 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re,

ivan27 à dit:
Est-il possible de rajouter une condition à vos propositions et de récupérer uniquement la liste des noms pour lesquels la valeur en colonne D est différente de "NON".

Solution annulée, ça ne va pas...

A+

R@chid · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Bonjour @ tous,
Voir PJ

@ + +

job75 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re,

ivan27 à dit:
Est-il possible de rajouter une condition à vos propositions et de récupérer uniquement la liste des noms pour lesquels la valeur en colonne D est différente de "NON".

On remplace les "NON" par des "#N/A" puis on supprime leurs lignes :

Code:

Private Sub Worksheet_Activate()
Dim celdest As Range, sup As Range, t, rest(), n&, i&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON" puis suppression des lignes
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "#N/A", xlWhole
  On Error Resume Next 's'il n'y a pas de "#N/A"
  Set sup = celdest(, -1).Resize(.Rows.Count).SpecialCells(xlCellTypeConstants, 16)
  Intersect(sup.EntireRow, celdest(, -1).Resize(.Rows.Count, 3)).Delete xlUp
  On Error GoTo 0
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(.Rows.Count, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(.Rows.Count, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Fichier (3).

A+

BOISGONTIER · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Bonjour,

>Est-il possible de rajouter une condition à vos propositions et de récupérer uniquement la liste des noms pour lesquels la valeur en colonne D est différente de "NON".

Sélectionner B3😀22
=Fréquents(noms;dates;ColD)
valider avec maj+ctrl+entrée

Pour que les dates n'apparaissent pas:

Sélectionner B3:C22
=Fréquents(noms;dates;ColD)
valider avec maj+ctrl+entrée

Code:

Function Fréquents(champ As Range, dt As Range, ColD As Range)
  Set d1 = New Dictionnaire
  Set d2 = New Dictionnaire
  temp = champ
  temp2 = dt.Value2
  temp3 = ColD
  For i = LBound(temp) To UBound(temp)
    c = temp(i, 1)
    If c <> "" And UCase(temp3(i, 1)) <> "NON" Then
       If d1.Existe(c) Then
         d1.affecte c, d1.item(c) + 1
         If temp2(i, 1) > d2.item(c) Then d2.affecte c, temp2(i, 1)
       Else
         d1.ajout c, 1
         d2.ajout c, temp2(i, 1)
       End If
    End If
  Next i
  Dim b()
  ReDim b(1 To d1.count, 1 To 3)
  i = 1
  For Each c In d1.listeCles
    b(i, 1) = c: b(i, 2) = d1.item(c): b(i, 3) = d2.item(c)
    i = i + 1
  Next
  Call Tri(b, 1, d1.count)
  Fréquents = b
End Function

JB

ivan27 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re bonjour à tous et merci pour votre réactivité et le qualité de vos propositions.
@ bientôt,

Ivan

job75 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re,

Si l'on teste le fichier (3) sur 34000 lignes, on se rendra compte que la suppression des "#N/A" prend beaucoup de temps.

Car il y a beaucoup de lignes disjointes à supprimer.

Pour accélérer il faut préalablement faire un tri pour mettre les "#N/A" en bas de la feuille :

Code:

Private Sub Worksheet_Activate()
Dim celdest As Range, sup As Range, t, rest(), n&, i&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON"
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "#N/A", xlWhole
  'tri pour accélérer
  celdest(, -1).Resize(.Rows.Count, 3).Sort celdest(, -1), xlAscending, Header:=xlYes
  'suppression des lignes des #N/A
  On Error Resume Next 's'il n'y a pas de "#N/A"
  Set sup = celdest(, -1).Resize(.Rows.Count).SpecialCells(xlCellTypeConstants, 16)
  Intersect(sup.EntireRow, celdest(, -1).Resize(.Rows.Count, 3)).Delete xlUp
  On Error GoTo 0
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(.Rows.Count, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(.Rows.Count, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Fichier (4).

A+

job75 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re,

J'ai retesté sur 34000 lignes.

La fonction de JB post #19 et la macro de job75 post #21 s'exécutent toutes deux en 1,37 seconde.

A+

job75 · 1 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Re,

En fait il n'est pas nécessaire de supprimer les lignes :

Code:

Private Sub Worksheet_Activate()
Dim celdest As Range, x As Variant, i&, t, rest(), n&
Set celdest = [B2] 'la cellule qu'on veut...
Application.ScreenUpdating = False
celdest.Resize(, 2).EntireColumn.Insert 'ajout de 2 colonnes auxiliaires
With Sheets("BD").[A1].CurrentRegion
  celdest(, 0).Resize(.Rows.Count) = .Columns(1).Value 'dates
  celdest.Resize(.Rows.Count) = .Columns(3).Value 'noms
  celdest(, -1).Resize(.Rows.Count) = .Columns(4).Value 'les "NON"
  'remplacement des "NON"
  celdest(, -1).Resize(.Rows.Count).Replace "NON", "zzz", xlWhole
  'tri pour mettre les "zzz" en bas
  celdest(, -1).Resize(.Rows.Count, 3).Sort celdest(, -1), xlAscending, Header:=xlYes
  'nouvelle hauteur du tableau à étudier
  x = Application.Match("zzz", celdest(, -1).Resize(.Rows.Count), 0)
  If IsError(x) Then i = .Rows.Count Else i = x - 1
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
  t = celdest(, 0).Resize(i, 2) 'matrice, plus rapide
End With
ReDim rest(1 To UBound(t), 1 To 3)
rest(1, 2) = "NOM": rest(1, 3) = "NOMBRE"
n = 1
For i = 2 To UBound(t)
  If t(i, 2) <> "" Then
    If t(i, 2) <> t(i - 1, 2) Then
      n = n + 1
      rest(n, 1) = t(i, 1) 'date
      rest(n, 2) = t(i, 2) 'nom
      rest(n, 3) = 1 'fréquence
    Else
      rest(n, 3) = rest(n, 3) + 1
    End If
  End If
Next
With celdest(, 0).Resize(n, 3)
  .Value = rest
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes
End With
If n > 21 Then n = 21
celdest(n + 1).Resize(Rows.Count - n - celdest.Row + 1, 2).Delete xlUp
celdest(, -1).Resize(, 2).EntireColumn.Delete 'en commentaire pour voir
t = Me.UsedRange 'repositionne la barre de défilement verticale
End Sub

Fichier (5).

Mais ça ne fait pas gagner beaucoup de temps => 1,32 seconde sur 34000 lignes.

A+

BOISGONTIER · 2 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Bonjour,

Version Mac sans module de classe

Code:

Function Fréquents(champ As Range, dt As Range, ColD As Range)
  Dim b():  ReDim b(1 To champ.Rows.count, 1 To 3)
  temp = champ
  temp2 = dt.Value2
  temp3 = ColD
  n = 0
  For i = LBound(temp) To UBound(temp)
      c = temp(i, 1)
      If c <> "" And UCase(temp3(i, 1)) <> "NON" Then
      témoin = False
      For j = 1 To n
        If b(j, 1) = c Then p = j: témoin = True
      Next j
      If témoin Then
        b(p, 1) = c: b(p, 2) = b(p, 2) + 1
        If temp2(i, 1) > b(p, 3) Then b(p, 3) = temp2(i, 1)
      Else
         n = n + 1
         b(n, 1) = c: b(n, 2) = 1: b(n, 3) = temp2(i, 1)
      End If
    End If
  Next i
  Call Tri(b, 1, n)
  Fréquents = b
End Function

Fonction FrequenceTexte() classique: http://boisgontierjacques.free.fr/fichiers/fonctionsperso/FonctionFrequenceTexteMac.xls

JB

job75 · 2 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Bonjour Jacques, le forum,

Ta solution est parfaite.

Sur 34000 lignes ta fonction s'exécute en 0,35 seconde.

Bonne journée.

job75 · 10 Février 2015

Re : Recherche dans une BD et tri d'une liste par fréquence

Bonjour à tous,

Au cas où quelqu'un repasserait par là, j'ai fait une erreur sur l'ordre des arguments des doubles tris.

Au lieu de :

Code:

'-----
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , , celdest(, 0), xlDescending, Header:=xlYes
'-----
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), xlDescending, Header:=xlYes

il faut écrire :

Code:

'-----
  'tri sur les noms puis décroissant sur les dates
  celdest(, 0).Resize(i, 2).Sort celdest, , celdest(, 0), , xlDescending, Header:=xlYes
'-----
  'tri décroissant sur les nombres puis sur les dates
  .Sort celdest(, 2), xlDescending, , celdest(, 0), , xlDescending, Header:=xlYes

A+

Effectuez une recherche sur Excel Downloads...

Recherche dans une BD et tri d'une liste par fréquence

ivan27

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

R@chid

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

ivan27

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires

Nous accordons de l'importance à votre vie privée