Supprimer des lignes à chaque changement de libellé d'une même colonne

[zakintos84]

Bonjour à tous,

J'ai pas mal navigué sur les forums mais je n'ai (apparemment) pas trouvé la solution à mon problème.
Voilà les faits (si j'arrive à être clair) :
J'ai une extraction Excel d'environ 3500 lignes tous les mois pour laquelle je dois garder uniquement les 20 premières lignes de chaque nom(libellé) qui apparaît dans la première colonne du tableau sachant que le nombre de lignes par libellé(nom) varie d'un mois sur l'autre. Le problème est donc le suivant (sachant que je ne connais rien au macro) :
Que doit-on faire pour que la macro conserve les 20 premières lignes de chaque nom et qu'à chaque nouveau nom, la macro conserve les 20 premières lignes s'y rapportant et ainsi de suite à chaque changement de nom...???
J'espère avoir été clair...

Merci d'avance pour votre aide amis d'Excel !!!!

 

[job75]

Re : Supprimer des lignes à chaque changement de libellé d'une même colonne

Bonsoir zakintos84,

Essayez cette macro :

Sub Noms()
Dim tablo1, tablo2, i As Long, n As Long
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
  .Sort .Columns(1), Header:=xlYes 'ligne de titre
  tablo1 = .Columns(1)
  tablo2 = tablo1
  For i = 2 To UBound(tablo1)
    If tablo1(i, 1) <> tablo1(i - 1, 1) Then
      n = 1
    Else
      n = n + 1
      If n > 20 Then tablo2(i, 1) = ""
    End If
  Next
  .Columns(1) = tablo2
  .Sort .Columns(1), Header:=xlYes
  On Error Resume Next
  .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

L'exécution sera rapide car on utilise des tableaux.

Nota 1 : je fais 2 tris, au début pour classer les noms et éliminer les cellules vides, à la fin pour placer en bas du tableau les cellules effacées. Si vous ne voulez pas de tri, n'hésitez pas à le dire.

Nota 2 : pour ces tris j'ai supposé qu'il y a une 1ère ligne de titres => Header:=xlYess

A+

 

[job75]

Re : Supprimer des lignes à chaque changement de libellé d'une même colonne

Re,

J'ai édité mon post précédent car j'avais oublié 2 lignes en fin de macro :

On Error Resume Next
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

A+

 

[job75]

Re : Supprimer des lignes à chaque changement de libellé d'une même colonne

Re,

Si l'on ne veut pas de tri... Eh bien n'en faisons pas :

Sub Noms()
Dim tablo1, tablo2, n As Long, i As Long
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
  tablo1 = .Columns(1)
  tablo2 = tablo1
  n = 1
  For i = 2 To UBound(tablo1)
    If tablo1(i, 1) <> tablo1(i - 1, 1) Then
      n = 1
    Else
      n = n + 1
      If n > 20 Then tablo2(i, 1) = ""
    End If
  Next
  .Columns(1) = tablo2
  On Error Resume Next
  .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Bonne fin de soirée.

 

[job75]

Re : Supprimer des lignes à chaque changement de libellé d'une même colonne

Bonjour le fil, le forum,

La macro du post #4 nécessite que les noms identiques soient groupés.

Voici une macro qui fonctionne dans tous les cas de figure.

Le tableau est trié mais l'ordre initial est rétabli à la fin grâce à une colonne auxiliaire :

Sub Les20Premiers()
Dim tablo1, tablo2, n As Long, i As Long
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Columns(2).Insert xlToRight 'colonne auxiliaire
With ActiveSheet.UsedRange
  .Cells(1, 2) = 1
  .Columns(2).DataSeries 'série
  .Sort .Columns(1) 'tri sur les noms
  tablo1 = .Columns(1)
  tablo2 = tablo1
  n = 1
  For i = 2 To UBound(tablo1)
    If tablo1(i, 1) <> tablo1(i - 1, 1) Then
      n = 1
    Else
      n = n + 1
      If n > 20 Then tablo2(i, 1) = ""
    End If
  Next
  .Columns(1) = tablo2
  .Sort .Columns(1) 'tri sur les noms
  On Error Resume Next
  .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .Sort .Columns(2), xlAscending, Header:=xlNo 'tri sur les nombres
  .Columns(2).Delete xlToLeft 'suppression de la colonne auxiliaire
End With
End Sub

Fichier joint.

A+

 

[zakintos84]

Re : Supprimer des lignes à chaque changement de libellé d'une même colonne

Bonjour job75,

Je viens d'essayer la macro....et c'est parfait !!! Enocre un grand merci et un grand bravo !!!! 😀