doublons qui se suivent dans colonne

[dacyrix]

bonjour tout le monde
Si en K plusieurs noms se suivent de façon identiques je voudrais garder uniquement les dernières lignes DU NOM . tout est bien expliqué dans le fichier joint
merci de votre aide

 

[job75]

Bonjour dacyrix,

Sub SupprimeDoublons()
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
d.comparemode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
For i = Range("K" & Rows.Count).End(xlUp).Row To 1 Step -1
  x = Cells(i, 11) & Cells(i, 12)
  If x <> "" Then If d.exists(x) Then Rows(i).Resize(5).Delete Else d(x) = ""
Next
End Sub

C'est jouable s'il n'y a pas des milliers de zones à supprimer.

A+

 

[job75]

Re,

J'ai créé le fichier joint de 25 000 lignes.

La macro précédente ne s'en sort pas, j'ai quitté par le Gestionnaire des tâches.

Alors j'ai écrit cette macro :

Sub SupprimeDoublons()
Dim t#, d As Object, derlig&, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
derlig = Range("K" & Rows.Count).End(xlUp).Row
With Range("M1:M" & derlig) 'colonne auxiliaire
  .Value = 1
  For i = derlig To 1 Step -1
    x = Cells(i, 11) & Cells(i, 12)
    If x <> "" Then If d.exists(x) Then Cells(i, 13).Resize(5) = "a" Else d(x) = ""
  Next
  .EntireRow.Sort .Cells(1), xlAscending, Header:=xlNo 'tri pour accélérer
  On Error Resume Next 's'il n'y a pas de SpecialCell
  .SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  .Value = ""
End With
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00\s") 'mesure facultative
End Sub

Chez moi sur Win 10 - Excel 2013 elle s'exécute en 11,4 secondes, c'est acceptable.

A+

 

[dacyrix]

Re,

J'ai créé le fichier joint de 25 000 lignes.

La macro précédente ne s'en sort pas, j'ai quitté par le Gestionnaire des tâches.

Alors j'ai écrit cette macro :

Sub SupprimeDoublons()
Dim t#, d As Object, derlig&, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
derlig = Range("K" & Rows.Count).End(xlUp).Row
With Range("M1:M" & derlig) 'colonne auxiliaire
  .Value = 1
  For i = derlig To 1 Step -1
    x = Cells(i, 11) & Cells(i, 12)
    If x <> "" Then If d.exists(x) Then Cells(i, 13).Resize(5) = "a" Else d(x) = ""
  Next
  .EntireRow.Sort .Cells(1), xlAscending, Header:=xlNo 'tri pour accélérer
  On Error Resume Next 's'il n'y a pas de SpecialCell
  .SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  .Value = ""
End With
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00\s") 'mesure facultative
End Sub

Chez moi sur Win 10 - Excel 2013 elle s'exécute en 11,4 secondes, c'est acceptable.

A+

merci énormément
que faut_il modifier ds le code car chaque 1ere ligne en B C sont fusionnées et là çà plante car les cellules sont de
taille différentes?

 

[job75]

Re,

On aura remarqué que très peu d'objets "flèches" (Line) ont été recopiés lors de la création du fichier (1).

J'ai donc créé les 10 000 flèches par cette macro :

Sub CopieShape()
Dim c As Range, i&
Application.ScreenUpdating = False
Set c = [D6] 'puis D7
Selection.Copy 'selectionner au préalable la flèche de la cellule c
For i = 1 To 4999
  ActiveSheet.Paste
  Selection.Top = c.Offset(5 * i).Top + c.Offset(5 * i).Height / 2
  Selection.Left = c.Left + 2
Next
End Sub

Mais alors pour l'exécution de la macro du post #3 Excel ne s'en sort pas.

10 000 Shapes c'est ingérable.

Bonne nuit.

 

[job75]

Re,

Concernant votre question sur les cellules fusionnées la macro du post #3 ne peut pas fonctionner car on effectue un tri.

Par contre celle du post #2 ne doit pas poser de problème.

Vous pourriez quand même nous indiquer le nombre de lignes de votre fichier réel...

Re-bonne nuit.

 

[job75]

Bonjour dacyrix, le forum,

Il n'y avait que 20 "flèches" dans le fichier (1).

Si on les supprime la macro s'exécute en 4,5 secondes, c'est édifiant !!!

Fichier (2).

Pour les cellules fusionnées même principe : les défusionner.

Bonne journée.

 

[job75]

Re,

Dans ce fichier (3) les cellules telles que B5:C5, B10:C10... sont fusionnées.

Leur traitement est très simple :

Range("B5:C" & derlig).UnMerge 'défusionne les cellules en colonnes B:C
'-----
Intersect([B:C], [L:L].SpecialCells(xlCellTypeConstants, 2).EntireRow).Merge 'refusionne

La durée d'exécution de la macro passe à 6,4 secondes.

A+

 

[dacyrix]

bonjour,
je vous envoie l'original en gros tout ce qui est jaune seulement doit etre supprimé pour cet exemple
car c'est un doublon de ce qui est juste en dessous merci d'avance

 

[dacyrix]

Re,

Dans ce fichier (3) les cellules telles que B5:C5, B10:C10... sont fusionnées.

Leur traitement est très simple :

Range("B5:C" & derlig).UnMerge 'défusionne les cellules en colonnes B:C
'-----
Intersect([B:C], [L:L].SpecialCells(xlCellTypeConstants, 2).EntireRow).Merge 'refusionne

La durée d'exécution de la macro passe à 6,4 secondes.

A+

bonjour,
je vous envoie l'original en gros tout ce qui est jaune seulement doit etre supprimé pour cet exemple
car c'est un doublon de ce qui est juste en dessous merci d'avance

 

[job75]

Re,

Il faudrait nous indiquer quels sont les critères que vous voulez utiliser pour définir les doublons, donc quelles sont les colonnes à étudier.

A priori, comme il y a peu de lignes, la macro de mon post #2 devrait suffire.

A+

 

[dacyrix]

bonsoir,
par ex: en K5326 K5334 K5340 j'ai 3 fois le même nom qui se suivent idem en colonne L 3 fois 22h / 6h. Aussi en J il y a une date & heure de sauvegarde. le but est de garder les lignes en fait du plus récent en supprimant les lignes A5326 à A5339 pour garder seulement A5340:A5345 donc la dernière sauvegarde
autrement dit : peu importe le nombre de noms en K qui se suivent je veux en garder qu'1 le + récent du meme nom mais en gardant les sauvegardes + anciennes
si vous remontez vers le haut vous constaterez qu'il n'y a pas deux fois le meme nom qui se suit
car j'ai déjà fait l'élimination manuellement
j'espère que c'est un peu plus clair
merci à vous

 

[job75]

Re,

Je n'ai absolument rien compris, quelles colonnes faut-il tester ?

Dans la macro du post #2 vous voyez (j'espère) que je teste les colonnes K (11) et L (12).

A+

 

[job75]

Bonjour dacyrix, le forum,

Bon je teste avec la date (sans l'heure), le nom et le quart en colonnes J K L.

4 zones de 6 lignes sont à supprimer, vous avez oublié la zone 4192:4197.

Méthode sans tri du post #2 :

Sub SupprimeDoublons()
'se lance par les touches Ctrl+D
Dim t#, d As Object, i&, x$, n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
For i = Range("K" & Rows.Count).End(xlUp).Row To 4 Step -1
  If IsDate(Cells(i, 10)) And Cells(i, 11) <> "" And Cells(i, 12) <> "" Then
    x = Int(Cells(i, 10)) & Cells(i, 11) & Cells(i, 12)
    If d.exists(x) Then Rows(i).Resize(6).Delete: n = n + 1 Else d(x) = ""
  End If
Next
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox n & " zones de 6 lignes supprimées en " & Format(Timer - t, "0.00 \s")
End Sub

Méthode avec tri du post #8 :

Sub SupprimeDoublons()
'se lance par les touches Ctrl+D
Dim t#, d As Object, derlig&, i&, x$, n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
derlig = Range("K" & Rows.Count).End(xlUp).Row
Range("B4:C" & derlig).UnMerge 'défusionne les cellules en colonnes B:C
With Range("X4:X" & derlig) 'colonne auxiliaire
  .Value = 1
  For i = derlig To 4 Step -1
    If IsDate(Cells(i, 10)) And Cells(i, 11) <> "" And Cells(i, 12) <> "" Then
      x = Int(Cells(i, 10)) & Cells(i, 11) & Cells(i, 12)
      If d.exists(x) Then Cells(i, 24).Resize(6) = "a": n = n + 1 Else d(x) = ""
    End If
  Next
  .EntireRow.Sort .Cells(1), xlAscending, Header:=xlNo 'tri pour accélérer
  On Error Resume Next 's'il n'y a pas de SpecialCell
  .SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  .Value = ""
End With
[D:D].Replace "du", 0
Intersect([B:C], [D:D].SpecialCells(xlCellTypeConstants, 1).EntireRow).Merge 'refusionne
[D:D].Replace 0, "du"
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox n & " zones de 6 lignes supprimées en " & Format(Timer - t, "0.00 \s")
End Sub

Avec si peu de lignes supprimées c'est rapide sauf pour le 3ème fichier comme on s'y attendait.

Bonne journée.

 

[dacyrix]

Bonjour,
encore merci pour votre patience et votre perspicacité ,votre travail
tout fonctionne parfaitement et le résultat est parfait
désolé pour les incompréhensions