Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel macro de frederic sigonneau sur les doublonst?

macro de frederic sigonneau sur les doublonst?

10 réponses
Avatar
rick
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
MichDenis
Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance
Avatar
rick
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance






Avatar
MichDenis
Bonjour Rick,

Si j'ai bien compris, pour qu'il y ait un doublon, il doit y avoir une correspondance exacte du contenu des 5 cellules de la même
ligne A, E, F, H, I.

Quel est l'événement qui doit déclencher cette macro ?

Cette section de ton message n'est pas claire :

Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.

Donne un exemple du contenu des 5 colonnes avant le message et après que l'usager ait répondu OUI.


Salutations!





"rick" a écrit dans le message de news:
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu
as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance






Avatar
rick
c'est à la fin de l'import de mes données, via une macro de mon bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

123456 12345 6789 1 890
123456 12345 6789 1 890
123456


si j'ai

Bonjour Rick,

Si j'ai bien compris, pour qu'il y ait un doublon, il doit y avoir une correspondance exacte du contenu des 5 cellules de la même
ligne A, E, F, H, I.

Quel est l'événement qui doit déclencher cette macro ?

Cette section de ton message n'est pas claire :

Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.

Donne un exemple du contenu des 5 colonnes avant le message et après que l'usager ait répondu OUI.


Salutations!





"rick" a écrit dans le message de news:
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu
as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance











Avatar
MichDenis
Bonjour Rick,

La procédure concatère et copie les valeurs des 5 colonnes que tu as retenues dans la colonne HJ15:HJ200

Sur cette colonne, une boucle vérifie si chaque ligne est un doublon d'une autre ligne et donne le choix à l'usager de supprimer ou
non la ligne qui est en doublons.

Il va falloir que tu te débrouilles avec ça.


à copier dans un module standard.
Tu dois adapter le nom de la feuille
'-------------------------------------------
Sub IdentifierDoublons()

Dim Rg As Range, C As Range, T As Range

With Worksheets("Feuil1")
Set Rg = .Range("HJ15:HJ200")
Rg.FormulaLocal = _
"=" & .Range("$A15").Address(0, 0) & _
"&" & .Range("$E15").Address(0, 0) & "&" _
& .Range("$F15").Address(0, 0) _
& "&" & .Range("$H15").Address(0, 0) & _
"&" & .Range("$I15").Address(0, 0)
.Range("B15:B20").Value = .Range("B15:B20").Value
End With

For Each C In Rg
Set T = Rg.Find(C, LookIn:=xlValues, _
SearchDirection:=xlNext)
If Not T Is Nothing Then
firstAddress = T.Address
Do
If T.Address <> C.Address Then
If MsgBox("La ligne " & T.Row & " est un doublon " & _
"de la ligne " & C.Row & "." & _
vbCrLf & vbCrLf & _
"Désirez-vous supprimer la ligne " & T.Row & "?", _
vbCritical + vbYesNo, "Présence d'un doublon") = vbYes Then
With Worksheets("Feuil1")
.Range("A" & T.Row & ":HI" & T.Row).Delete (xlUp)
End With
Set T = Rg.FindNext(C)
Else
Set T = Rg.FindNext(C)
End If
Else
Exit Do
End If
Loop While Not T Is Nothing
End If
Next
Rg.Clear
Set Rg = Nothing
End Sub
'---------------------------------------


Salutations!





"rick" a écrit dans le message de news:
c'est à la fin de l'import de mes données, via une macro de mon bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

123456 12345 6789 1 890
123456 12345 6789 1 890
123456


si j'ai

Bonjour Rick,

Si j'ai bien compris, pour qu'il y ait un doublon, il doit y avoir une correspondance exacte du contenu des 5 cellules de la même
ligne A, E, F, H, I.

Quel est l'événement qui doit déclencher cette macro ?

Cette section de ton message n'est pas claire :

Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.

Donne un exemple du contenu des 5 colonnes avant le message et après que l'usager ait répondu OUI.


Salutations!





"rick" a écrit dans le message de news:
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ?
Tu
as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance











Avatar
rick
ne tiens pas compte du message qui est incomplet j'ai fait une erreur d
emanip.

donc au fait, a la fin de l'import de mes données qui se lance via un bouton
de commande.

je souhaite faire le controle de ma plage de A15 à HI200

par exemple:

ligne 15: 123456 1234 567 1
OUI
ligne16: 123456 1234 567 1
OUI
ligne 17: 123456 1234 567 1
OUI

je voit que j'ai 3 doublons, il faut que je puisse avoir un message du type

Vous avez des doublons a la ligne 16 et 17: voulez vous quand meme intégré
ces doublons?

SI l'utilisateur repond oui, alors je viendrai mettre automatiquement un
caractere subsidiaire:

ligne 15: 123456 1234 567 1A
OUI
ligne16: 123456 1234 567 1B
OUI
ligne 17: 123456 1234 567 1C
OUI

si l'utilisateur repond NON, alors j'efface les deux doublons et j'aurai
seuement ca:

ligne 15: 123456 1234 567 1
OUI

merci d'avance
cela donnera

Bonjour Rick,

Si j'ai bien compris, pour qu'il y ait un doublon, il doit y avoir une correspondance exacte du contenu des 5 cellules de la même
ligne A, E, F, H, I.

Quel est l'événement qui doit déclencher cette macro ?

Cette section de ton message n'est pas claire :

Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.

Donne un exemple du contenu des 5 colonnes avant le message et après que l'usager ait répondu OUI.


Salutations!





"rick" a écrit dans le message de news:
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu
as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance











Avatar
rick
désolé jai eu des blem avec mon message la.

AU fait c'est à la fin de l'import de mes données, via une macro de mon
bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

ligne 15: 123456 12345 6789 1 890
ligne 16: 123456 12345 6789 1 890
ligne 17: 123456 12345 6789 1 890


Le message que je souhaite affiché ici, est vous avez des doublons,
souhaitez vous conservez ces doublons, si l'utilisateur repond oui, alors je
met automatiquement un caractere de substitution sur la colonne H
comme ceci:

ligne 15: 123456 12345 6789 1A 890
ligne 16: 123456 12345 6789 1B 890
ligne 17: 123456 12345 6789 1C 890

si il repond NON, j'efface les doublons, et j'aurai ceci:


ligne 15: 123456 12345 6789 1 890

merci d'avance




c'est à la fin de l'import de mes données, via une macro de mon bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

123456 12345 6789 1 890
123456 12345 6789 1 890
123456


si j'ai

Bonjour Rick,

Si j'ai bien compris, pour qu'il y ait un doublon, il doit y avoir une correspondance exacte du contenu des 5 cellules de la même
ligne A, E, F, H, I.

Quel est l'événement qui doit déclencher cette macro ?

Cette section de ton message n'est pas claire :

Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.

Donne un exemple du contenu des 5 colonnes avant le message et après que l'usager ait répondu OUI.


Salutations!





"rick" a écrit dans le message de news:
ma plage est de A15 à HI200,

5 colonne définnisent une combinaison:

A et E et F et H et I

on doit avoir une combinaison identique,je souhaite donc afficher un message
box quand il y a des doublons et afficher un message à l'utilisateur:
Souhaite t'il entrer cette facilité : si il repond oui cette combinaison est
intégré à cette plage en entrant dans la colonne F un caractere subsidiaire
pour les differencier.
Si il repond non , le doublon est supprimé.

merci d'avance




Bonjour Rick,

Pour savoir si une macro fait son travail convenablement , il faut d'abord savoir et connaître les attentes de l'usager. À cet
égard, tu as omis de faire une description minutieuse de ton problème, où étaient tes données ? Comment elles sont disposées ? Tu
as
oublié aussi de mentionner l'adresse des plages que tu veux comparer (les doublons) ! Et lorsque la macro trouve un doublon, que
doit-elle faire avec cela ?


Salutations!



"rick" a écrit dans le message de news:
bonjour,

j'utilise la macro de frederic pour l'elimination de doublons.

en modifiant le code suivant mes besoins,c'est a dire lorsqu'il a des
doublons afficher un message box et proposer OUI pour conserver ce doublon et
donc rajouter un caractere supplémentaire sur la colonne E pour les
différencier.
ou NON dans le message box,qui supprime le doublon(la ligne).

J'ai essayé d'apporter des modifs dans le code, mais cela bloque et cela ne
fonctionne pas comme je souhaite.

l'apercu de la macro:

Dim CheckRows As Range
Dim ColumnsToMatch As Variant
Dim DeleteDuplicates As Boolean
Dim FormatDuplicates As Boolean
Dim WriteListOfDuplicates As Boolean
Dim AddRowNumberToList As Boolean
Dim lLBound As Long
Dim lUBound As Long
Dim CheckRange As Range
Dim SubArray As Variant
Dim FieldsCollection As New Collection
Dim RowNumberCollection As New Collection
Dim Dummy As Long
Dim DuplicateRange As Range
Dim DuplicatesExist As Boolean
Dim lRow As Long
Dim CollectionKey As String
Dim OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long
Dim messdoublons As Byte


'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
Set CheckRows = Rows("15:20")
ColumnsToMatch = Array("A", "E", "F")
DeleteDuplicates = False
FormatDuplicates = False
WriteListOfDuplicates = True
AddRowNumberToList = True

lLBound = LBound(ColumnsToMatch)
lUBound = UBound(ColumnsToMatch)

Set CheckRange = Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)

ReDim OffsetValue(lUBound - lLBound + 1)

For Counter = lLBound To lUBound
OffsetValue(Counter) = Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter

On Error Resume Next
SubArray = CheckRange.Value
For lRow = 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey = ""
For Counter = lLBound To lUBound
CollectionKey = CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0



« modification de codes apporté au code»
If DuplicatesExist = False Then
MsgBox "Aucun doublons n'est présent", vbInformation
Else

With DuplicateRange.EntireRow
'If WriteListOfDuplicates Then

If AddRowNumberToList Then
messdoublons = MsgBox("DOublons existant sur la ou les
lignes,SOuhaitez vous conservez cette ligne" & Range("A1"), vbYesNo +
vbInformation)
Select Case reponse
Case vbNo
.Delete
Unload UserForm1


Case vbOK
Unload UserForm1

End Select

Set StartCell = Range("A1")
For Each Element In RowNumberCollection
StartCell.Value = "Row " & Element
Set StartCell = StartCell.Offset(1, 0)
Next Element
End If
'End If

End With
End If

merci d'avance













Avatar
MichDenis
Bonsoir Rick,

Pour la durée de la procédure, j'ajoute une colonne BJ15:BJ200 où seront concaténées les données des colonnes A, E, F, H, I.

Un tri croissant sera appliqué à l'ensemble de la plage A15:BJ200 en utilisant la colonne BJ comme critère.

Lorsque l'usager répond non à la suppression des doublons, Une lettre de "A à Z " est ajoutée au contenu de chacune des données en
colonnne H.

Dans la procédure, tu dois déterminer le nom de la feuille où sont tes données.

Tu copies cette procédure dans un module standard.

'--------------------------------------------
Sub SupprimerDoublons()

Dim K As Integer, A As Integer
Dim Rg As Range, P As Integer
Dim NomFeuille As String

NomFeuille = "Feuil1" 'à déterminer

With Worksheets(NomFeuille)
Set Rg = .Range("HJ15:HJ200")
Rg.FormulaLocal = _
"=" & UCase(.Range("$A15").Address(0, 0)) & _
"&" & UCase(.Range("$E15").Address(0, 0)) & "&" _
& UCase(.Range("$F15").Address(0, 0)) _
& "&" & UCase(.Range("$H15").Address(0, 0)) & _
"&" & UCase(.Range("$I15").Address(0, 0))
Rg.Value = Rg.Value
Rg.Offset(, -217).Resize(, 218).Sort Key1:=Rg(1, 1)
End With

Do While Rg(K + 1, 1).Row < Rg.Row + Rg.Rows.Count
A = WorksheetFunction.CountIf(Rg, Rg(K + 1, 1))
If A > 1 Then
If MsgBox("Il y a " & A - 1 & " doublon(s) de la ligne " _
& Rg(K + 1).Row & "." & vbCrLf & vbCrLf & _
"Désirez-vous supprimer ces doublons ? ", _
vbCritical + vbYesNo, "Doublons") = vbYes Then
Rg(K + 1, 1).Offset(1).Resize(A - 1).EntireRow.Delete
A = A - 1
Else
With Worksheets(NomFeuille)
For Each r In .Range("H" & Rg(K + 1, 1).Row & _
":H" & Rg(K + 1, 1).Row + A - 1)
r.Value = r & Chr(65 + P)
P = P + 1
Next
P = 0
End With
End If
Else
A = A + 1
End If
K = K + A
Loop
Rg.Clear
Set Rg = Nothing
End Sub
'--------------------------------------------


Salutations!




"rick" a écrit dans le message de news:
désolé jai eu des blem avec mon message la.

AU fait c'est à la fin de l'import de mes données, via une macro de mon
bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

ligne 15: 123456 12345 6789 1 890
ligne 16: 123456 12345 6789 1 890
ligne 17: 123456 12345 6789 1 890


Le message que je souhaite affiché ici, est vous avez des doublons,
souhaitez vous conservez ces doublons, si l'utilisateur repond oui, alors je
met automatiquement un caractere de substitution sur la colonne H
comme ceci:

ligne 15: 123456 12345 6789 1A 890
ligne 16: 123456 12345 6789 1B 890
ligne 17: 123456 12345 6789 1C 890

si il repond NON, j'efface les doublons, et j'aurai ceci:


ligne 15: 123456 12345 6789 1 890

merci d'avance
Avatar
MichDenis
Essaie plutôt cette version :


'------------------------------------------
Sub SupprimerDoublons()

Dim K As Integer, A As Integer
Dim Rg As Range, P As Integer
Dim NomFeuille As String

NomFeuille = "Feuil1" 'à déterminer

Application.EnableEvents = False

With Worksheets(NomFeuille)
Set Rg = .Range("HK15:HK200")
Rg.FormulaLocal = _
"=" & UCase(.Range("$A15").Address(0, 0)) & _
"&" & UCase(.Range("$E15").Address(0, 0)) & "&" _
& UCase(.Range("$F15").Address(0, 0)) _
& "&" & UCase(.Range("$H15").Address(0, 0)) & _
"&" & UCase(.Range("$I15").Address(0, 0))
Rg.Value = Rg.Value
Rg.Offset(, -1).Formula = "=row()"
Rg.Offset(, -1).Value = Rg.Offset(, -1).Value
Rg.Offset(, -218).Resize(, 219).Sort Key1:=Rg(2, 1)
End With

Do While Rg(K + 1, 1).Row < Rg.Row + Rg.Rows.Count
A = WorksheetFunction.CountIf(Rg, Rg(K + 1, 1))
If A > 1 Then
Rg(K + 1, 1).Resize(A).EntireRow.Select
If MsgBox("Il y a " & A - 1 & " doublon(s) de la ligne " _
& Rg(K + 1).Row & "." & vbCrLf & vbCrLf & _
"Désirez-vous supprimer ces doublons ? ", _
vbCritical + vbYesNo, "Doublons") = vbYes Then
Rg(K + 1, 1).Offset(1).Resize(A - 1).EntireRow.Delete
A = A - 1
Else
With Worksheets(NomFeuille)
For Each r In .Range("H" & Rg(K + 1, 1).Row & _
":H" & Rg(K + 1, 1).Row + A - 1)
r.Value = r & Chr(65 + P)
P = P + 1
Next
P = 0
End With
End If
Else
A = A + 1
End If
K = K + A
Loop
Rg.Offset(, -218).Resize(, 219).Sort Key1:=Rg(2, 1).Offset(, -1)
Rg.Offset(, -1).Resize(, 2).Clear
Range("A15").Select
Set Rg = Nothing
Application.EnableEvents = True
End Sub
'------------------------------------------


Salutations!










"MichDenis" a écrit dans le message de news: u%
Bonsoir Rick,

Pour la durée de la procédure, j'ajoute une colonne BJ15:BJ200 où seront concaténées les données des colonnes A, E, F, H, I.

Un tri croissant sera appliqué à l'ensemble de la plage A15:BJ200 en utilisant la colonne BJ comme critère.

Lorsque l'usager répond non à la suppression des doublons, Une lettre de "A à Z " est ajoutée au contenu de chacune des données en
colonnne H.

Dans la procédure, tu dois déterminer le nom de la feuille où sont tes données.

Tu copies cette procédure dans un module standard.

'--------------------------------------------
Sub SupprimerDoublons()

Dim K As Integer, A As Integer
Dim Rg As Range, P As Integer
Dim NomFeuille As String

NomFeuille = "Feuil1" 'à déterminer

With Worksheets(NomFeuille)
Set Rg = .Range("HJ15:HJ200")
Rg.FormulaLocal = _
"=" & UCase(.Range("$A15").Address(0, 0)) & _
"&" & UCase(.Range("$E15").Address(0, 0)) & "&" _
& UCase(.Range("$F15").Address(0, 0)) _
& "&" & UCase(.Range("$H15").Address(0, 0)) & _
"&" & UCase(.Range("$I15").Address(0, 0))
Rg.Value = Rg.Value
Rg.Offset(, -217).Resize(, 218).Sort Key1:=Rg(1, 1)
End With

Do While Rg(K + 1, 1).Row < Rg.Row + Rg.Rows.Count
A = WorksheetFunction.CountIf(Rg, Rg(K + 1, 1))
If A > 1 Then
If MsgBox("Il y a " & A - 1 & " doublon(s) de la ligne " _
& Rg(K + 1).Row & "." & vbCrLf & vbCrLf & _
"Désirez-vous supprimer ces doublons ? ", _
vbCritical + vbYesNo, "Doublons") = vbYes Then
Rg(K + 1, 1).Offset(1).Resize(A - 1).EntireRow.Delete
A = A - 1
Else
With Worksheets(NomFeuille)
For Each r In .Range("H" & Rg(K + 1, 1).Row & _
":H" & Rg(K + 1, 1).Row + A - 1)
r.Value = r & Chr(65 + P)
P = P + 1
Next
P = 0
End With
End If
Else
A = A + 1
End If
K = K + A
Loop
Rg.Clear
Set Rg = Nothing
End Sub
'--------------------------------------------


Salutations!




"rick" a écrit dans le message de news:
désolé jai eu des blem avec mon message la.

AU fait c'est à la fin de l'import de mes données, via une macro de mon
bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

ligne 15: 123456 12345 6789 1 890
ligne 16: 123456 12345 6789 1 890
ligne 17: 123456 12345 6789 1 890


Le message que je souhaite affiché ici, est vous avez des doublons,
souhaitez vous conservez ces doublons, si l'utilisateur repond oui, alors je
met automatiquement un caractere de substitution sur la colonne H
comme ceci:

ligne 15: 123456 12345 6789 1A 890
ligne 16: 123456 12345 6789 1B 890
ligne 17: 123456 12345 6789 1C 890

si il repond NON, j'efface les doublons, et j'aurai ceci:


ligne 15: 123456 12345 6789 1 890

merci d'avance
Avatar
MichDenis
Essaie plutôt cette version


'-----------------------------------------
Sub SupprimerDoublons()

Dim K As Integer, A As Integer
Dim Rg As Range, P As Integer
Dim NomFeuille As String

NomFeuille = "Feuil1" 'à déterminer

Application.EnableEvents = False

With Worksheets(NomFeuille)
Set Rg = .Range("HK15:HK200")
Rg.FormulaLocal = _
"=" & UCase(.Range("$A15").Address(0, 0)) & _
"&" & UCase(.Range("$E15").Address(0, 0)) & "&" _
& UCase(.Range("$F15").Address(0, 0)) _
& "&" & UCase(.Range("$H15").Address(0, 0)) & _
"&" & UCase(.Range("$I15").Address(0, 0))
Rg.Value = Rg.Value
Rg.Offset(, -1).Formula = "=row()"
Rg.Offset(, -1).Value = Rg.Offset(, -1).Value
Rg.Offset(, -218).Resize(, 219).Sort Key1:=Rg(2, 1)
End With

Do While Rg(K + 1, 1).Row < Rg.Row + Rg.Rows.Count
A = WorksheetFunction.CountIf(Rg, Rg(K + 1, 1))
If A > 1 Then
Rg(K + 1, 1).Resize(A).EntireRow.Select
If MsgBox("Il y a " & A - 1 & " doublon(s) de la ligne " _
& Rg(K + 1).Row & "." & vbCrLf & vbCrLf & _
"Désirez-vous supprimer ces doublons ? ", _
vbCritical + vbYesNo, "Doublons") = vbYes Then
Rg(K + 1, 1).Offset(1).Resize(A - 1).EntireRow.Delete
A = 1
Else
With Worksheets(NomFeuille)
For Each r In .Range("H" & Rg(K + 1, 1).Row & _
":H" & Rg(K + 1, 1).Row + A - 1)
r.Value = r & Chr(65 + P)
P = P + 1
Next
P = 0
End With
End If
End If
If A = 0 Then A = 1
K = K + A
Loop
Rg.Offset(, -218).Resize(, 219).Sort Key1:=Rg(2, 1).Offset(, -1)
Rg.Offset(, -1).Resize(, 2).Clear
Range("A15").Select
Set Rg = Nothing
Application.EnableEvents = True
End Sub
'-----------------------------------------


Salutations!






"MichDenis" a écrit dans le message de news: u%
Bonsoir Rick,

Pour la durée de la procédure, j'ajoute une colonne BJ15:BJ200 où seront concaténées les données des colonnes A, E, F, H, I.

Un tri croissant sera appliqué à l'ensemble de la plage A15:BJ200 en utilisant la colonne BJ comme critère.

Lorsque l'usager répond non à la suppression des doublons, Une lettre de "A à Z " est ajoutée au contenu de chacune des données en
colonnne H.

Dans la procédure, tu dois déterminer le nom de la feuille où sont tes données.

Tu copies cette procédure dans un module standard.

'--------------------------------------------
Sub SupprimerDoublons()

Dim K As Integer, A As Integer
Dim Rg As Range, P As Integer
Dim NomFeuille As String

NomFeuille = "Feuil1" 'à déterminer

With Worksheets(NomFeuille)
Set Rg = .Range("HJ15:HJ200")
Rg.FormulaLocal = _
"=" & UCase(.Range("$A15").Address(0, 0)) & _
"&" & UCase(.Range("$E15").Address(0, 0)) & "&" _
& UCase(.Range("$F15").Address(0, 0)) _
& "&" & UCase(.Range("$H15").Address(0, 0)) & _
"&" & UCase(.Range("$I15").Address(0, 0))
Rg.Value = Rg.Value
Rg.Offset(, -217).Resize(, 218).Sort Key1:=Rg(1, 1)
End With

Do While Rg(K + 1, 1).Row < Rg.Row + Rg.Rows.Count
A = WorksheetFunction.CountIf(Rg, Rg(K + 1, 1))
If A > 1 Then
If MsgBox("Il y a " & A - 1 & " doublon(s) de la ligne " _
& Rg(K + 1).Row & "." & vbCrLf & vbCrLf & _
"Désirez-vous supprimer ces doublons ? ", _
vbCritical + vbYesNo, "Doublons") = vbYes Then
Rg(K + 1, 1).Offset(1).Resize(A - 1).EntireRow.Delete
A = A - 1
Else
With Worksheets(NomFeuille)
For Each r In .Range("H" & Rg(K + 1, 1).Row & _
":H" & Rg(K + 1, 1).Row + A - 1)
r.Value = r & Chr(65 + P)
P = P + 1
Next
P = 0
End With
End If
Else
A = A + 1
End If
K = K + A
Loop
Rg.Clear
Set Rg = Nothing
End Sub
'--------------------------------------------


Salutations!




"rick" a écrit dans le message de news:
désolé jai eu des blem avec mon message la.

AU fait c'est à la fin de l'import de mes données, via une macro de mon
bouton de
commande.
Je verifie toute la plage de A15 à HI200

Par exemple si:

j'ai

ligne 15: 123456 12345 6789 1 890
ligne 16: 123456 12345 6789 1 890
ligne 17: 123456 12345 6789 1 890


Le message que je souhaite affiché ici, est vous avez des doublons,
souhaitez vous conservez ces doublons, si l'utilisateur repond oui, alors je
met automatiquement un caractere de substitution sur la colonne H
comme ceci:

ligne 15: 123456 12345 6789 1A 890
ligne 16: 123456 12345 6789 1B 890
ligne 17: 123456 12345 6789 1C 890

si il repond NON, j'efface les doublons, et j'aurai ceci:


ligne 15: 123456 12345 6789 1 890

merci d'avance