Suppression des doublons + copie d'elements

[stefb44]

Bonjour,

Je parcours avec attention les pages de ce forum qui me permets de progesser rapidement en vba sur Excel.
J'arrive à mes limites, et voici ma question.

Je gère quotidiennement un tableau ou apparait l'ensemble des projets que nous suivons au bureau.
Sur certaines colonnes (Colonnes B à J), je note des informations qui me permettent de suivre l'activité: QUI, QUAND, COMBIEN DE TEMPS, etc...

Chaque mois, je reçois les nouvelles affaires avec des évolutions sur certaines colonnes (Colonnes K à V). Il existe des lignes supplémentaires, et des lignes en moins (Chantiers terminés).

Je souhaite supprimer les doublons sur le critère de la colonne L, mais sans perdre les informations notés dans les colonnes B à J.

Mais voilà, je n'arrive pas à copier toutes les informations, ou je supprime les mauvaises lignes.
Pouvez-vous m'aider à m'y retrouver.

Voici le code que j'utilise :

Sub supprimeDoublons()

MaCellule = InputBox("Veuillez saisir l'adresse de la 1ere cellule à comparer (Indiquer L2)")
Range(MaCellule).Select

ActiveCell.CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes

Donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
z = 2
w = z + 1
While ActiveCell <> ""
If ActiveCell = Donnee1 Then
Range("B" & z & ":J" & z).Select
Selection.Copy
Range("B" & w).Select
ActiveSheet.Paste
Range("L" & w).Select
ActiveCell.EntireRow.Delete
Donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
z = z + 1
w = w + 1
Else
Donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
End If
Wend

End Sub

Merci de votre aide.
Stef

 

[job75]

Re : Suppression des doublons + copie d'elements

Bonjour stefb44, bienvenue sur XLD,

Un fichier (allégé et/ou zippé <48ko) avec le tableau d'origine (non trié) permettrait de voir exactement quelle est la zone à traiter.

En général, pour supprimer les doublons, on fait ceci :

Sub SupprimeDoublons()
Dim lig As Long
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
  If Cells(lig, "L") = Cells(lig - 1, "L") Then Rows(lig).Delete
Next
End Sub

On parcourt toujours le tableau en commençant par la dernière ligne et en remontant.

Si ce sont les valeurs correspondant au 1er des doublons que l'on garde, il n'y a rien à copier.

Noter qu'en VBA il est généralement parfaitement inutile de sélectionner quoi que ce soit.

A+

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonjour,

J'ai inséré en pièce jointe le fichier utilisé.
Pour info, les colonnes M & N ne sont normalement pas vides, mais comportent le détail des projets donc masqués.

Pourquoi indiquez vous qu'en VBA il n'est pas besoin de sélectionner quoi que ce soit ?

Merci pour votre analyse de mon fichier et de ses macros, et me donner une solution pour copie avant suppression des doublons.

Pour infos, j'ai placé les projets en cours avec les anciennes valeurs, et la nouvelle base avec les valeurs mises à jour (Modification des valeurs dans les colonnes S à V).

Merci,
Stef

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonsoir,

A noter que ce sont les 1er des doublons que l'on doit supprimer.

 

[job75]

Re : Suppression des doublons + copie d'elements

Bonsoir stefb44,

Pourquoi indiquez vous qu'en VBA il n'est pas besoin de sélectionner quoi que ce soit ?

Question à 100 sous... Parce qu'il n'est pas besoin, et que beaucoup sur ce forum doivent se le mettre dans le crâne.

Quant à votre fichier, pour garder le dernier des doublons, modifiez la macro ainsi :

Sub SupprimeDoublons()
Dim lig As Long
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
  If Cells(lig, "L") = Cells(lig - 1, "L") Then
    [COLOR="Red"]Cells(lig - 1, 1).Resize(, 22) = Cells(lig, 1).Resize(, 22).Value 'copie ligne inférieure sur ligne supérieure, colonnes A:V[/COLOR]
    Rows(lig).Delete
  End If
Next
End Sub

Nota 1 : les "nouvelle données" colonnes Q:V seront bien sûr supprimées si elles appartiennent à des doublons supprimés.

Nota 2 : désactivez le filtre automatique avant de lancer la macro.

A+

 

[job75]

Re : Suppression des doublons + copie d'elements

Re,

Mais sans doute faut-il copier les cellules inférieures sur les cellules supérieures seulement si elles ne sont pas vides :

Sub SupprimeDoublons()
Dim lig As Long, [COLOR="red"]col As Byte[/COLOR]
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
  If Cells(lig, "L") = Cells(lig - 1, "L") Then
    [COLOR="Red"]For col = 1 To 22 'colonnes A:V
      If Cells(lig, col) <> "" Then Cells(lig - 1, col) = Cells(lig, col) 'copie ligne inférieure sur ligne supérieure
    Next[/COLOR]
    Rows(lig).Delete
  End If
Next
End Sub

A+

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonsoir Job75 et merci pour les informations.

La solution proposée semble marcher correctement.
Je l'ai juste un peu modifier pour ne copier que les colonnes A à J, et supprimé la 1ère ligne, et non la deuxième.

Cela donne le code suivant:
'
Sub SupprimeDoublons_New()
Selection.AutoFilter
'
Dim lig As Long
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
'
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
If Cells(lig, "L") = Cells(lig - 1, "L") Then
Cells(lig, 1).Resize(, 10) = Cells(lig - 1, 1).Resize(, 10).Value 'copie ligne inférieure sur ligne supérieure, colonnes A:J
Rows(lig - 1).Delete
End If
Next
'
End Sub

Par contre, il y a t'il possibilité de supprimer la ligne qui n'a pas de doublon (donc le projet est terminé donc plus à suivre), ou mieux copier cette ligne dans une autre feuille (On garde une trace), en indiquant éventuellement la date de suppression de la ligne.

Enore merci,
Stef

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Re,

Je n'avais pas vu la nouvelle proposition.
Je dois juste copier les valeurs que j'avais dans les lignes initiales. Donc si elles sont vides, tant pis, je les copie quand même.

De plus, la proposition proposée risque d'allonger le temps de traitement déjà assez long dans la suppression.

Qu'en pensez-vous ?

Stef,

 

[job75]

Re : Suppression des doublons + copie d'elements

Bonjour stefb44, le forum,

On peut éviter la boucle col en faisant un Copier/Collage spécial-Valeurs-Blancs non compris :

Sub SupprimeDoublons()
Dim lig As Long
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
  If Cells(lig, "L") = Cells(lig - 1, "L") Then
    [COLOR="Red"]Rows(lig).Copy
    Rows(lig - 1).PasteSpecial xlPasteValues, SkipBlanks:=True[/COLOR]
    Rows(lig).Delete
  End If
Next
End Sub

Mais cela est très long car à chaque fois le presse-papier est alimenté, une sélection est créée...

J'ai testé sur votre fichier :

- avec la boucle col => 0,20 s

- avec PasteSpecial => 1,15 s

Une dernière remarque stefb44.

Pour modifier une base de donnée en évitant le problème des doublons, on peut utiliser un UserForm.

Une ComboBox permet de choisir la ligne à modifier, les valeurs de la ligne sont copiées dans des TextBox que l'on peut ensuite modifier avant de les transférer dans les cellules.

A+

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonjour,

Je vais laisser le fichier original sans rajouter de conditions sur la copie des colonnes.
Auriez vous par contre une solution à me proposer pour :

"Il y a t'il possibilité de supprimer la ligne qui n'a pas de doublon (donc le projet est terminé donc plus à suivre), ou mieux copier cette ligne dans une autre feuille (On garde une trace), en indiquant éventuellement la date de suppression de la ligne."

Encore merci pour les précisions que vous apportez sur chaque modification.

Stef,

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonsoir,
Je n'ai pas eu de proposition sur ma dernière requête.
Quelqu'un aurait il une solution a me proposer ?

Pour rappel, la demande était :
Par contre, il y a t'il possibilité de supprimer la ligne qui n'a pas de doublon (donc le projet est terminé donc plus à suivre), ou mieux copier cette ligne dans une autre feuille (On garde une trace), en indiquant éventuellement la date de suppression de la ligne.(donc le projet est terminé donc plus à suivre), ou mieux copier cette ligne dans une autre feuille (On garde une trace), en indiquant éventuellement la date de suppression de la ligne.

D'avance merci,
Stef

 

[job75]

Re : Suppression des doublons + copie d'elements

Bonjour stefb44, le forum,

Je n'ai pas eu de proposition sur ma dernière requête.

Parce que cette demande n'est guère orthodoxe : normalement il faudrait une colonne spéciale pour indiquer que le projet est terminé.

Mais si vous voulez absolument supprimer les lignes sans doublons en colonne L, voyez la macro SupprimeSansDoublons ci-dessous.

Elle doit bien sûr être lancée avant la macro SupprimeDoublons

Et pour accélérer ces 2 macros, on repère par un "X" en colonne W (vide) les lignes à supprimer :

Sub SupprimeSansDoublons()
Dim lig As Long, plage As Range
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = 2 To Range("L65536").End(xlUp).Row
  If Cells(lig, "L") <> Cells(lig - 1, "L") And Cells(lig, "L") <> Cells(lig + 1, "L") _
    Then Cells(lig, "W") = "X" 'repérage des lignes à supprimer
Next
On Error Resume Next
Set plage = Columns("W").SpecialCells(xlCellTypeConstants).EntireRow
plage.Copy Sheets("Feuil1").Rows(Sheets("Feuil1").Range("L65536").End(xlUp).Row + 1) 'sauvegarde en Feuil1
plage.Delete
End Sub

Sub SupprimeDoublons()
Dim lig As Long
Application.ScreenUpdating = False
Rows("1:" & Range("L65536").End(xlUp).Row).Sort Key1:=Range("L1"), Order1:=xlAscending, Header:=xlYes
For lig = Range("L65536").End(xlUp).Row To 3 Step -1
  If Cells(lig, "L") = Cells(lig - 1, "L") Then
    Cells(lig - 1, 1).Resize(, 22) = Cells(lig, 1).Resize(, 22).Value 'copie ligne inférieure sur ligne supérieure, colonnes A:V
    Cells(lig, "W") = "X" 'repérage des lignes à supprimer
  End If
Next
On Error Resume Next
Columns("W").SpecialCells(xlCellTypeConstants).EntireRow.Delete
End Sub

La suppression des lignes se fait en bloc, à la fin de chaque macro.

A+

 

[stefb44]

Re : Suppression des doublons + copie d'elements

Bonjour job75,

Merci bien de cette réponse.
Je l'insère dans mon fichier, er fais des essais.
Je vous tiens au courant,

Slts,
Stef