suppression doublon

[matt31]

Bonjour,

j'aurais besoin d'aide dans la réalisation d'une macro permettant d'effacer les lignes en doublon.

J'ai une macro qui va ouvrir plusieurs fichiers et recopier toutes les lignes de la ligne 3 à la dernière ligne où C n'est pas vide et tout recoller sur un fichier récapitulatif.

Le problème est que si je lance plusieurs fois la macro cela recommence à copier les mêmes données.

Je voudrais donc que cela copie mais que cela ne me garde que la dernière ligne copiée. Comme ça si j'ai fait des modifications sur la ligne je ne conserve que la dernière version. Un seul élement de la ligne ne change jamais et me sert de référence c'est la cellule C.

J'ai donc essayé de faire une recherche sur cette cellule C et d'effacer la ligne si C est retrouvée mais ça ne marche par.
Je mets en pièces jointes 3 fichiers (2 avec les fichiers à copier et 1 qui est le fichier récap : dossier annuel).

Merci par avance pour votre aide.

 

[jp14]

Re : suppression doublon

Bonjour

Une question :
quelle est la donnée qui permet de déterminer la ligne avec la dernière version ?

JP

 

[PMO2]

Re : suppression doublon

Bonjour,

Dans les fichiers EM 141 - S 01.xls et EM 141 - S 02.xls, je retrouve les mêmes identificateurs IEP en colonne "C".
S'agit-il
1) d'une erreur de votre part en créant l'exemple. Auquel cas les identificateurs sont bien uniques.
2) les identificateurs en colonne "C" ne sont pas uniques et peuvent correspondre à plusieurs personnes (on ne peut donc pas s'y référer pour éliminer les doublons)
Merci de le préciser.

 

[matt31]

Re : suppression doublon

effectivement j'avais simplement fait une copie de EM 141 - S 01 en modifiant uniquement le nom en colonne A.
J'ai corrigé et maintenant le nombre en C est différent pour chaque ligne de chaque fichier.

En lançant la macro "recap" je voudrais que cela copie sur le fichier dossier annuel. C'est bon ça fonctionne mais cela recopie systématiquement. Or les lignes peuvent être modifiées et je ne voudrais garder que la dernière version. Tout ce qui est susceptible d'être modifié se situe à partir de la colonne K.

Pour jp14 la ligne avec la dernière version est celle qui est enregistrée sur le fichier du type EM 141 - S xx où le xx correspond au numéro de semaine (c'est ce que j'appelle fichier semaine).
Il faudrait que la macro copie sur le fichier semaine, vérifie sur le fichier de destination (dossiers annuels - EM 141) s'il existe en C une ligne ayant la même valeur. Dans un tel cas, il efface cette ligne et colle celle du fichier semaine. Dans le cas contraire, il colle directement celle du fiche semaine.

Encore merci

bien sûr pj oubliée... 😱

 

[jp14]

Re : suppression doublon

Bonjour

Ci dessous un code qui utilise une collection pour trouver les doublons.

Algorithme simplifié
Remplir une collection avec le numéro de la colonne c et le numéro de ligne
Mémoriser la première ligne vide

Insérer les données
Recherche des doublons dans la nouvelle zone
Si on trouve un doublon, on recherche dans la collection le numéro, ce qui permet la suppression de la ligne.

Sub Recap()
Dim Ligdebcopie As Long
Dim DerLig1 As Long, DerLig2 As Long, i As Long, Réf_VaR As Long, k As Integer, l As Long
Dim Chemin As String, Nom_de_ce_fichier As String
Dim Temporaire As String
Dim Coll As New Collection
Dim Doublontrouve As Boolean
Dim Element As Variant
Dim Tablo() As String
Dim Ligne As Long
Dim Trouve As Boolean
'Application.ScreenUpdating = False

Nom_de_ce_fichier = ThisWorkbook.Name
Chemin = ThisWorkbook.Path
Col = "c"
With Sheets("2012")
On Error Resume Next
For Each Cellule In .Range(Col & "2:" & Col & .Range(Col & .Rows.Count).End(xlUp).Row)
    Coll.Add Cellule & " " & Cellule.Row, CStr(Cellule) ' création d'une collection pour triuver les doublons
Next Cellule
On Error GoTo 0
Ligdebcopie = .Range("C" & Rows.Count).End(xlUp).Row + 1
End With


For j = 1 To 2
    DerLig2 = Range("C" & Rows.Count).End(xlUp).Row

    début = 1 + DerLig2
    Temporaire = "EM 141 - S " & Right("0" & CStr(j), 2) & ".xls"
    Workbooks.Open Filename:=Chemin & "\" & Temporaire

     Windows(Temporaire).Activate
    DerLig1 = Range("C" & Rows.Count).End(xlUp).Row

    'copie des dossiers sur le fichier de dossiers annuels
    
        Range("A3:Y" & DerLig1).Copy
        Windows(Nom_de_ce_fichier).Activate
        Range("A" & début).PasteSpecial
        Range("A" & début).Select
        Application.DisplayAlerts = False
        Windows(Temporaire).Close

'tri fichier dossiers annuels
'supprimer les lignes en doubles
With Sheets("2012")
For Each Cellule In .Range(Col & Ligdebcopie & ":" & Col & .Range(Col & .Rows.Count).End(xlUp).Row)
    On Error GoTo suite
    Doublontrouve = False
    Coll.Add Cellule & " " & Cellule.Row, CStr(Cellule)
    On Error GoTo 0
    If Doublontrouve = True Then
        For Each Element In Coll
            Tablo = Split(Element)
            If InStr((CStr(Cellule.Value)), Tablo(0)) > 0 Then
                Ligne = CLng(Tablo(UBound(Tablo)))
                .Rows(Ligne).Clear 'Shift:=xlDown
                Exit For
            End If
        Next Element
    End If
Next Cellule

End With

Windows(Nom_de_ce_fichier).Activate
DerLig2 = Range("g" & Rows.Count).End(xlUp).Row
Rows("3:" & DerLig2).Select
Selection.Sort Key1:=Range("g3"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
          

 Next j
 
On Error GoTo 0
Exit Sub
suite:
Doublontrouve = True
 Resume Next
End Sub

A tester et à terminer

JP

 

[matt31]

Re : suppression doublon

merci de ton aide.

je ne comprends pas trop ta démarche mais ça ne marche pas. Cela copie de manière aléatoire (jamais 2 fois les mêmes lignes copiées) mais pas toutes les lignes qui se répètent plusieurs fois alors qu'identiques.

 

[PMO2]

Re : suppression doublon

Bonjour,

J'ai repris intégralement le code. Voyez si cela peut vous convenir.

Cordialement.

 

[matt31]

Re : suppression doublon

Merci beaucoup c'est exactement ça.

Une dernière petite question, est-il possible d'imposer la hauteur des lignes?
Au début cela copie avec une hauteur de 15 par ligne (comme sur les lignes des fichiers EM 141 - S 01 et S 02) puis ensuite cela change.

Encore merci

 

[PMO2]

Re : suppression doublon

Bonjour,

A qui s'adresse cette réponse ?

Merci beaucoup c'est exactement ça.

Une dernière petite question, est-il possible d'imposer la hauteur des lignes?
Au début cela copie avec une hauteur de 15 par ligne (comme sur les lignes des fichiers EM 141 - S 01 et S 02) puis ensuite cela change.

 

[matt31]

Re : suppression doublon

pardon, c'est pour votre proposition à vous.

Pour la hauteur des lignes j'ai essayé de rajouter

Rows(3 & ":" & [A65536].End(xlUp).Row).RowHeight = 15

à l'enregistrement du fichier par exemple mais sur un fichier vierge cela modifie tout de même la ligne 2.

 

[PMO2]

Re : suppression doublon

Re,
Quant à la hauteur des lignes, c'est votre classeur "dossiers annuels - EM 141.xls" que vous avez fourni comme cela (avec la hauteur des lignes qui change à partir de la ligne 151) et ce n'est pas le programme qui interfère.
Pour y remédier, il suffit de créer une nouvelle feuille et d'y copier votre bandeau de titres OU de sélectionner toutes les cellules, régler la hauteur des lignes à votre convenance puis régler la hauteur de la ligne 1 et la hauteur de la ligne 2.

Il n'est donc pas nécessaire de mettre une instruction dans le code.

Cordialement.

 

[matt31]

Re : suppression doublon

comme le classeur "dossiers annuels - EM 141" va contenir environ 30000 lignes, je voulais simplement éviter de le faire manuellement.
Je vais voir si j'arrive à arranger un peu cette instruction, sinon je ferai le tout manuellement.

Encore merci pour votre aide, je vais pouvoir passer à la suite du fichier.

 

[PMO2]

Re : suppression doublon

Bon, puisque c'est vous je l'ai fait manuellement (c'est très rapide).
En pièce jointe, le classeur avec les bonnes hauteurs de ligne.
Bonne suite.

 

[matt31]

Re : suppression doublon

je vous remercie mais je vais quand même chercher comment modifier le code pour que cela se fasse tout seul... 😉

 

[PMO2]

Re : suppression doublon

Je me suis mal fait comprendre. Le problème ne vient pas de l'exécution du programme mais du classeur récapitulatif qui était mal formaté dès le départ. Une fois ce dernier bien formaté, l'inconvénient ne risque plus de se manifester.

Maintenant, puisque vous y tenez voici le code avec la modification signalée par des /////////////

Option Explicit

Const FEUILLE_RECAP As String = "2012"

Sub Recap_pmo()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R1 As Range
Dim R2 As Range
Dim i&
Dim j&
Dim k&
Dim A$
Dim var1
Dim var2
Application.ScreenUpdating = False
Set WB1 = ThisWorkbook
Set S1 = WB1.Sheets.Add
For i& = 1 To 60
  On Error Resume Next
  Set WB2 = GetObject(WB1.Path & "\" & "EM 141 - S " & Right("0" & CStr(i&), 2) & ".xls")
  On Error GoTo 0
  If WB2 Is Nothing Then
    Err.Clear
  Else
    Set S2 = WB2.Sheets(1)
    S2.Range("A3:Y" & S2.Range("C" & Rows.Count).End(xlUp).Row).Copy
    If S1.UsedRange.Rows.Count = 1 Then
      S1.Range("A1").PasteSpecial
    Else
      S1.Range("A" & S1.UsedRange.Rows.Count + 1 & "").PasteSpecial
    End If
    Application.CutCopyMode = False
    Set S2 = Nothing
    WB2.Close
    Set WB2 = Nothing
  End If
Next i&
'--------
Set S2 = WB1.Sheets(FEUILLE_RECAP)
Set R2 = S2.Range("a1:y" & S2.Range("C" & Rows.Count).End(xlUp).Row & "")
var2 = R2
If UBound(var2, 1) = 2 Then
  S1.UsedRange.Copy
  S2.[a3].PasteSpecial
Else
  Set R1 = S1.UsedRange
  var1 = R1
  For i& = 1 To UBound(var2, 1)
    For k& = 1 To UBound(var1, 1)
      If var1(k&, 3) = var2(i&, 3) Then
        For j& = 1 To UBound(var2, 2)
          var2(i&, j&) = ""
        Next j&
        Exit For
      End If
    Next k&
  Next i&
  R2 = var2
  R1.Copy
  S2.Range("A" & S2.Range("C" & Rows.Count).End(xlUp).Row + 1).PasteSpecial
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
S1.Delete
Application.DisplayAlerts = True
'-----
S2.Activate
Set R2 = S2.Range("A1:Y" & S2.Range("C" & Rows.Count).End(xlUp).Row & "")
var2 = R2
For i& = UBound(var2, 1) To 3 Step -1
  If var2(i&, 3) = "" Then S2.Rows(i&).Delete
Next i&
S2.[a1].Select

'////////////////////////modif pour la hauteur des lignes/////////
If R2.Rows.Count > 2 Then
  Set R2 = S2.Rows("3:" & R2.Rows.Count & "")
  R2.RowHeight = 15
End If
'/////////////////////////////////////////////////////////////////

Application.ScreenUpdating = True
End Sub