doublons qui se suivent dans colonne
- Initiateur de la discussion dacyrix
- Date de début
job75
XLDnaute Barbatruc
Bonjour dacyrix,
C'est jouable s'il n'y a pas des milliers de zones à supprimer.
A+
Code:
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 SubA+
job75
XLDnaute Barbatruc
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 :
Chez moi sur Win 10 - Excel 2013 elle s'exécute en 11,4 secondes, c'est acceptable.
A+
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 :
Code:
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 SubA+
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
XLDnaute Barbatruc
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 :
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.
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 :
Code:
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 Sub10 000 Shapes c'est ingérable.
Bonne nuit.
job75
XLDnaute Barbatruc
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.
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
XLDnaute Barbatruc
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.
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
XLDnaute Barbatruc
Re,
Dans ce fichier (3) les cellules telles que B5:C5, B10:C10... sont fusionnées.
Leur traitement est très simple :
La durée d'exécution de la macro passe à 6,4 secondes.
A+
Dans ce fichier (3) les cellules telles que B5:C5, B10:C10... sont fusionnées.
Leur traitement est très simple :
Code:
Range("B5:C" & derlig).UnMerge 'défusionne les cellules en colonnes B:C
'-----
Intersect([B:C], [L:L].SpecialCells(xlCellTypeConstants, 2).EntireRow).Merge 'refusionneA+
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
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
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
XLDnaute Barbatruc
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+
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+
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
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
Pièces jointes
job75
XLDnaute Barbatruc
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+
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
XLDnaute Barbatruc
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 :
Méthode avec tri du post #8 :
Avec si peu de lignes supprimées c'est rapide sauf pour le 3ème fichier comme on s'y attendait.
Bonne journée.
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 :
Code:
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
Code:
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 SubBonne journée.
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
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
Discussions similaires
- Question
