OU INCLUSIF vs ET

Bonsoir:

Dans la macro suivante qui sert à dédoublonner un tableau Excel, l'auteur
indique que la recherche de doublons s'effectue sur plusieurs
colonnes mais que c'est le OU INCLUSIF qui est utilisé.
Est-il possibled'avoir à la place du OU INCLUSIF le ET (à moins qu'il
s'agisse du OU EXCLUSIF?) afin que par exemple le contenu du range
$A:$A,$C:$D soit considéré comme doublons que si le contenu respectif de
chacune des colonnes est identique.

Dans l'exemple ci-dessous, je souhaiterais que la ligne 3 soit considérée
comme doublons mais pas la ligne 4 (ce qui est le cas avec le OU INCLUSIF).

A,B,C,D
1,2,3,4
1,5,3,4
1,1,1,1

Remerciements.

Christophe
----------------------------------------------------------------------------
--------

Sub RemoveDuplicatesInList()
'leo.heuser@adslhome.dk, August 24, 2001/21-1-2002, Version 1.1.
'Cette procédure détruit ou met en évidence les doublons dans une liste.
'La destruction/mise en évidence procède par lignes entières.
'Une liste des doublons peut être constituée dans une nouvelle feuille,
'insérée après la feuille active. Les numéros des lignes concernées
'peuvent être ajoutées à la liste.
'La recherche de doublons peut s'effectuer sur plusieurs colonnes.
'Par exemple, la colonne A peut contenir plusieurs fois "Peter" et la
'colonne B plusieurs fois "Smith".
'Si le paramètre ColumnsToWatch est fixé à Array("A","B"), tous les doublons
'qui sont trouvés dans "A" OU "B" seront détruits/mis en évidence.
'C'est le OU inclusif qui est utilisé : A OU B OU LES DEUX
' A B
'1 Nom Prénom
'2 Peter Smith
'3 Ian Smith
'4 Dana Jones
'5 Peter Neal
'6 Peter Smith
'Avec ces contraintes, les lignes 3, 5 et 6 sont considérées
'comme des doublons. La ligne 6 n'apparaîtra qu'une seule fois
'dans le résultat final.

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 FieldCollection() 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 OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long

'Edit the next 6 lines to reflect the actual setup
'Set CheckRows = Rows("1:5000")
'ColumnsToMatch = Array("A:B")
'DeleteDuplicates = True
'FormatDuplicates = False
'WriteListOfDuplicates = True
'AddRowNumberToList = False

'les ligne suivantes définissant les input box ont été écrites par AV sur
MPFE
lgDéb = InputBox("Input first row number e.g. 2", "")
If lgDéb = "" Or lgDéb > 65535 Then Exit Sub

lgFin = InputBox("Input last row numberl", "")
If lgFin = "" Or lgFin > 65536 Or lgFin < lgDéb Then Exit Sub

On Error Resume Next
Set x = Application.InputBox("Select column or range of columns e.g. $A:$A",
"ColumnsToMatch", , , , , , 8)
Set CheckRows = Rows(lgDéb & ":" & lgFin)
ColumnsToMatch = Array(x.Address(0, 0))

DeleteDuplicates = InputBox("False ou True", "DeleteDuplicates", "True")
If DeleteDuplicates <> False And DeleteDuplicates <> True Then Exit Sub

FormatDuplicates = InputBox("False ou True", "FormatDuplicates", "False")
If FormatDuplicates <> False And FormatDuplicates <> True Then Exit Sub

WriteListOfDuplicates = InputBox("False ou True", "WriteListOfDuplicates",
"True")
If WriteListOfDuplicates <> False And WriteListOfDuplicates <> True Then
Exit Sub

AddRowNumberToList = InputBox("False ou True", "AddRowNumberToList",
"False")
If AddRowNumberToList <> False And AddRowNumberToList <> True Then Exit Sub
' fin lignes input box

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

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

ReDim OffsetValue(lUBound - lLBound + 1)
ReDim FieldCollection(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
For Counter = lLBound To lUBound
FieldCollection(Counter).Add _
Dummy, CStr(CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add _
CheckRange(lRow, 1).Row, _
CStr(CheckRange(lRow, 1).Row)
If Err.Number = 0 Then
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
Else
Err.Clear
End If
End If
Next Counter
End If
Next lRow
On Error GoTo 0

If DuplicatesExist = False Then
MsgBox "No duplicates exist.", vbInformation
Else
With DuplicateRange.EntireRow
If WriteListOfDuplicates Then
Worksheets.Add After:=DuplicateRange.Parent
.Copy Destination:=Range("A1")
If AddRowNumberToList Then
Columns("A").Insert
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
If FormatDuplicates Then .Font.ColorIndex = 3
If DeleteDuplicates Then .Delete
End With
End If

End Sub

Bonjour,

Solution possible dans ton premier fil de discussion (7/11 23:59).

FS
--
Frédéric Sigonneau [MVP Excel - né un sans-culottide]
Gestions de temps, VBA pour Excel :
http://perso.wanadoo.fr/frederic.sigonneau
Si votre question sur Excel est urgente, évitez ma bal !

Bonsoir:

Dans la macro suivante qui sert à dédoublonner un tableau Excel,
l'auteur

indique que la recherche de doublons s'effectue sur plusieurs
colonnes mais que c'est le OU INCLUSIF qui est utilisé.
Est-il possibled'avoir à la place du OU INCLUSIF le ET (à moins qu'il
s'agisse du OU EXCLUSIF?) afin que par exemple le contenu du range
$A:$A,$C:$D soit considéré comme doublons que si le contenu respectif de
chacune des colonnes est identique.

Dans l'exemple ci-dessous, je souhaiterais que la ligne 3 soit
considérée

comme doublons mais pas la ligne 4 (ce qui est le cas avec le OU
INCLUSIF).

A,B,C,D
1,2,3,4
1,5,3,4
1,1,1,1

Remerciements.

Christophe

--------------------------------------------------------------------------
--

--------

Sub RemoveDuplicatesInList()
'leo.heuser@adslhome.dk, August 24, 2001/21-1-2002, Version 1.1.
'Cette procédure détruit ou met en évidence les doublons dans une liste.
'La destruction/mise en évidence procède par lignes entières.
'Une liste des doublons peut être constituée dans une nouvelle feuille,
'insérée après la feuille active. Les numéros des lignes concernées
'peuvent être ajoutées à la liste.
'La recherche de doublons peut s'effectuer sur plusieurs colonnes.
'Par exemple, la colonne A peut contenir plusieurs fois "Peter" et la
'colonne B plusieurs fois "Smith".
'Si le paramètre ColumnsToWatch est fixé à Array("A","B"), tous les
doublons

'qui sont trouvés dans "A" OU "B" seront détruits/mis en évidence.
'C'est le OU inclusif qui est utilisé : A OU B OU LES DEUX
' A B
'1 Nom Prénom
'2 Peter Smith
'3 Ian Smith
'4 Dana Jones
'5 Peter Neal
'6 Peter Smith
'Avec ces contraintes, les lignes 3, 5 et 6 sont considérées
'comme des doublons. La ligne 6 n'apparaîtra qu'une seule fois
'dans le résultat final.

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 FieldCollection() 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 OffsetValue() As Long
Dim StartCell As Range
Dim Element As Variant
Dim Counter As Long

'Edit the next 6 lines to reflect the actual setup
'Set CheckRows = Rows("1:5000")
'ColumnsToMatch = Array("A:B")
'DeleteDuplicates = True
'FormatDuplicates = False
'WriteListOfDuplicates = True
'AddRowNumberToList = False

'les ligne suivantes définissant les input box ont été écrites par AV
sur

MPFE
lgDéb = InputBox("Input first row number e.g. 2", "")
If lgDéb = "" Or lgDéb > 65535 Then Exit Sub

lgFin = InputBox("Input last row numberl", "")
If lgFin = "" Or lgFin > 65536 Or lgFin < lgDéb Then Exit Sub

On Error Resume Next
Set x = Application.InputBox("Select column or range of columns e.g.
$A:$A",

"ColumnsToMatch", , , , , , 8)
Set CheckRows = Rows(lgDéb & ":" & lgFin)
ColumnsToMatch = Array(x.Address(0, 0))

DeleteDuplicates = InputBox("False ou True", "DeleteDuplicates", "True")
If DeleteDuplicates <> False And DeleteDuplicates <> True Then Exit Sub

FormatDuplicates = InputBox("False ou True", "FormatDuplicates",
"False")

If FormatDuplicates <> False And FormatDuplicates <> True Then Exit Sub

WriteListOfDuplicates = InputBox("False ou True",
"WriteListOfDuplicates",

"True")
If WriteListOfDuplicates <> False And WriteListOfDuplicates <> True Then
Exit Sub

AddRowNumberToList = InputBox("False ou True", "AddRowNumberToList",
"False")
If AddRowNumberToList <> False And AddRowNumberToList <> True Then Exit
Sub

' fin lignes input box

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

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

ReDim OffsetValue(lUBound - lLBound + 1)
ReDim FieldCollection(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
For Counter = lLBound To lUBound
FieldCollection(Counter).Add _
Dummy, CStr(CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value)
If Err.Number = 457 Then
Err.Clear
DuplicatesExist = True
RowNumberCollection.Add _
CheckRange(lRow, 1).Row, _
CStr(CheckRange(lRow, 1).Row)
If Err.Number = 0 Then
If DuplicateRange Is Nothing Then
Set DuplicateRange = _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange = Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
Else
Err.Clear
End If
End If
Next Counter
End If
Next lRow
On Error GoTo 0

If DuplicatesExist = False Then
MsgBox "No duplicates exist.", vbInformation
Else
With DuplicateRange.EntireRow
If WriteListOfDuplicates Then
Worksheets.Add After:=DuplicateRange.Parent
.Copy Destination:=Range("A1")
If AddRowNumberToList Then
Columns("A").Insert
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
If FormatDuplicates Then .Font.ColorIndex = 3
If DeleteDuplicates Then .Delete
End With
End If

End Sub