Discussion :

[BRUNO71]

BOnjour,

Un sujet mainte fois abordé, les doublons avec VBA Excel 2007…
Mon code qui fonctionne mais pas comme je le souhaiterai…

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[A2].Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess
For i = [A1048576].End(xlUp).Row To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then Rows(i).Delete
Next i
Application.Calculation = xlCalculationAutomatic

Après avoir copié des rangés depuis un autre classeur, certaine donné ne sont pas identique dans différente cellule en colonne H.
Les doublons sont triés à partir de la colonne D pour supprimer la ligne complète.

Comment dire à ma macro, tu ne supprime pas le doublon qui a des infos dans la cellule H mais tu supprime le doublon correspondant qui lui n’a pas d’infos dans la cellule H …

Houfff….suis-je clair !
Je n’arrive pas à trouver un sujet identique concernant les doublons…
Par avance merci….
Cordialement.

[EngueEngue]

suffit d'imbriquer un if dans ton if ...

[Marc-L]

Bonjour,

au niveau du tri il faudrait ajouter une deuxième clef sur la colonne H,
comme cela les cellules vides en H seront après celles remplies puis modifier la ligne n°6 ainsi :

If Cells(i, 1).Value = Cells(i - 1, 1).Value And Cells(i, 8).Value = "" Then Rows(i).Delete …

__________________________________________________________________________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

[BRUNO71]

Bonjour,

Merci Marc, avec ça c'est super...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
[A1].Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess
 
 For i = [A1048576].End(xlUp).Row To 2 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value And Cells(i, 8).Value = "" Then Rows(i).Delete
 
Next i
Application.Calculation = xlCalculationAutomatic

Une petite question en supplément :

Histoire de vérifier mon fichier, je crée plusieurs et même doublons...
Et là, malheur il me reste des doublons...
Je mets à nouveau l'exécution de ma macro et les doublons restant ne sont pas supprimés !

Pourquoi et comment changer celà ?

Merci beaucoup...

[Marc-L]

Afin de lever toute ambiguïté et d'éviter une perte de temps,
merci de présenter un exemple de doublons à conserver et de doublons à supprimer.

Si une ligne n'a rien dans la colonne H et n'est pas en doublon en A, faut-il la conserver ?

C'est pas bon xlGuess dans le tri, soit il y a des titres, soit il y en a pas ?!

Bref, un maximum d'informations s'impose, voir même un exemple en pièce jointe …

[BRUNO71]

Bonjour,

Merci pour ton aide...
Fichier excel refait pour l'essai...
Résultat souhaité, et bien qu'il ne reste que les ligne avec le commentaire en H et que tous les doublons n'y soient plus...

Merci, Marc.

[Invité]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Function Highlander(Init As Boolean, ParamArray Plage()) As Boolean
'..................................................
'La méthode Highlander, il ne peut en rester qu'un.
'Retourne True si doublon.
'..................................................
 
Static CollectDoublon As Collection
Dim T As String
Dim PlageIndex As Long
Dim myPlage As Range
Dim Col As Integer
If Init = False Then
Init = True
   Set CollectDoublon = Nothing
   Set CollectDoublon = New Collection
End If
 
 
T = "T"
For PlageIndex = 0 To UBound(Plage)
   Set myPlage = Plage(PlageIndex)
   For Col = 1 To myPlage.Columns.Count
    T = T & "_" & myPlage(1, Col)
   Next
Next
On Error Resume Next
CollectDoublon.Add T, T
If Err <> 0 Then Highlander = True
On Error GoTo 0
End Function
 
Private Sub CommandButton1_Click()
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Dim Init As Boolean
Dim MyRange As Range
Dim L As Long
Dim I As Long
Dim lignes() As Long
Set MyRange = ActiveSheet.UsedRange
Debug.Print "Sur 7 colonnes"
For L = 2 To MyRange.Rows.Count
   If Highlander(Init, MyRange(L, 1)) = True Then
    ReDim Preserve lignes(I)
    lignes(I) = L
    I = I + 1
   End If
Next
 
For I = UBound(lignes) To 0 Step -1
    MyRange(lignes(I), 1).EntireRow.Delete
Next
'[A2].Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess
'For i = [A1048576].End(xlUp).Row To 2 Step -1
'
'
'If Cells(i, 1).Value = Cells(i - 1, 1).Value And Cells(i, 8).Value = "" Then Rows(i).Delete
'
'Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
End Sub

[Marc-L]

Bruno, deux erreurs dans ton code :

1. tu tries sur la colonne D mais la colonne H doit aussi être triée en seconde clef comme déjà indiqué pourtant ‼
2. Dans la ligne n°8 (If), tu testes la première colonne qui est un numéro de fiche unique ! Serait-ce mieux sur la colonne D ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
    [A1].CurrentRegion.Sort [D1], xlAscending, [H1], , xlAscending, , , xlYes
 
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
     If Cells(i, 4).Value = Cells(i - 1, 4).Value And Cells(i, 8).Value = "" Then Rows(i).Delete
    Next i
 
       Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Ensuite à partir de la version 2007 il y a la méthode RemoveDuplicates pour supprimer les doublons …

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub DemoRemoveDuplicates()
    Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
 
    With [A1].CurrentRegion
        .Sort .[D1], xlAscending, .[H1], , xlAscending, , , xlYes
        .RemoveDuplicates 4, xlYes
    End With
 
       Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

__________________________________________________________________________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

[BRUNO71]

Bonjour,

Merci Marc....

Merci rdurupt pour cet exemple, mais la réponse de Marc me convient...

CDLT

[Marc-L]

Correction dans la démo de RemoveDuplicates : pour blinder manquaient les points devant les cellules clef …

Sinon remercier c'est bien, mais ici voter c'est aussi apprécié, cela encourage à te répondre la prochaine fois ! …