Il y a quelques ann=E9es AV m'avait tr=E8s gentillement adapt=E9 une
formidable macro de d=E9doublenage cr=E9=E9e par L=E9o Heuser en y ajoutant
des boites de saisies afin de ne pas avoir =E0 rentrer dans la macro
pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la
macro originale de L=E9o Heuser enl=E8ve les doublons quand par exemple
A et B et F sont identiques (c'est ce que je veux) alors que la
modification apport=E9e par AV supprime les doublons par exemple quand A
ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le probl=E8me car je voudrais le
meilleur des deux mondes macro d=E9doublonnage de Leo Heuser type A et B
et F et boites de saisies de AV.
Sub DuplicatesInList()
'leo.heuser@get2net.dk, August 17, 2001
'Cette proc=E9dure supprime les doublons ou en fait la liste.
'Elle supprime ou inclut dans la liste par lignes enti=E8res.
'Une liste des doublons peut =EAtre ins=E9r=E9e dans une nouvelle feuille
'apr=E8s la feuille active. Les num=E9ros de lignes peuvent =EAtre
ajout=E9s =E0 la liste.
'Plus d'une colonne peut =EAtre utilis=E9e pour trouver
'les doublons de la liste. Par exemple, la colonne A peut
'contenir plusieurs entr=E9es avec le nom "Peter"
'la colonne B plusieurs entr=E9es avec "Smith",
'la colonne F plusieurs entr=E9es avec "Oxford St."
'Passer =E0 l'argument ColumnsToMatch la valeur Array("A", "B", "F")
'va inclure dans la liste ou supprimer tous les doublons o=F9
'une correspondance existe entre "A" *et* "B" *et* "F"
' A B F
'1 Name Surname Address
'2 Peter Smith Oxford St.
'3 Peter Smith Regent St.
'4 Peter Jones Oxford St.
'5 Peter Smith Oxford St.
'Avec ces contraintes, seule la 5=E8me ligne est consid=E9r=E9e
'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre =E0 jour
'les param=E8tres de travail de la macro
'Set CheckRows =3D Rows("1:1000")
'ColumnsToMatch =3D Array("A", "B", "C")
'DeleteDuplicates =3D False
'FormatDuplicates =3D False
'WriteListOfDuplicates =3D True
'AddRowNumberToList =3D True
'les lignes suivantes d=E9finissant les input box ont =E9t=E9 =E9crites par
AV sur MPFE (ajout=E9 par Christophe Joly)
lgD=E9b =3D InputBox("Input first row number e.g. 1", "")
If lgD=E9b =3D "" Or lgD=E9b > 65535 Then Exit Sub
lgFin =3D InputBox("Input last row numberl", "")
If lgFin =3D "" Or lgFin > 65536 Or lgFin < lgD=E9b Then Exit Sub
On Error Resume Next
Set x =3D Application.InputBox("Select column or range of columns e.g.
$A:$A", "ColumnsToMatch", , , , , , 8)
Set CheckRows =3D Rows(lgD=E9b & ":" & lgFin)
ColumnsToMatch =3D Array(x.Address(0, 0))
DeleteDuplicates =3D InputBox("False ou True", "DeleteDuplicates",
"True")
If DeleteDuplicates <> False And DeleteDuplicates <> True Then Exit Sub
FormatDuplicates =3D InputBox("False ou True", "FormatDuplicates",
"False")
If FormatDuplicates <> False And FormatDuplicates <> True Then Exit Sub
WriteListOfDuplicates =3D InputBox("False ou True",
"WriteListOfDuplicates", "True")
If WriteListOfDuplicates <> False And WriteListOfDuplicates <> True
Then Exit Sub
AddRowNumberToList =3D InputBox("False ou True", "AddRowNumberToList",
"False")
If AddRowNumberToList <> False And AddRowNumberToList <> True Then Exit
Sub
Set CheckRange =3D Intersect(Range(ColumnsToMatch(lLBound) & _
":" & ColumnsToMatch(lLBound)), CheckRows)
ReDim OffsetValue(lUBound - lLBound + 1)
For Counter =3D lLBound To lUBound
OffsetValue(Counter) =3D Range(ColumnsToMatch(Counter) & ":" & _
ColumnsToMatch(Counter)).Column - CheckRange.Column
Next Counter
On Error Resume Next
SubArray =3D CheckRange.Value
For lRow =3D 1 To UBound(SubArray, 1)
If SubArray(lRow, 1) <> "" Then
CollectionKey =3D ""
For Counter =3D lLBound To lUBound
CollectionKey =3D CollectionKey & _
CheckRange(lRow, 1).Offset(0, _
OffsetValue(Counter)).Value
Next Counter
FieldsCollection.Add Dummy, CStr(CollectionKey)
If Err.Number =3D 457 Then
Err.Clear
DuplicatesExist =3D True
RowNumberCollection.Add CheckRange(lRow, 1).Row
If DuplicateRange Is Nothing Then
Set DuplicateRange =3D _
CheckRange.Cells(lRow, 1)
Else
Set DuplicateRange =3D Union(DuplicateRange, _
CheckRange.Cells(lRow, 1))
End If
End If
End If
Next lRow
On Error GoTo 0
If DuplicatesExist =3D False Then
MsgBox "No duplicates exist.", vbInformation
Else
With DuplicateRange.EntireRow
If WriteListOfDuplicates Then
Worksheets.Add After:=3DDuplicateRange.Parent
.Copy Destination:=3DRange("A1")
If AddRowNumberToList Then
Columns("A").Insert
Set StartCell =3D Range("A1")
For Each Element In RowNumberCollection
StartCell.Value =3D "Row " & Element
Set StartCell =3D StartCell.Offset(1, 0)
Next Element
End If
End If
If FormatDuplicates Then .Font.ColorIndex =3D 3
If DeleteDuplicates Then .Delete
End With
End If
End Sub
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
Stephan
leo.heu !!!Ta macro de dédoublonnage est trop géniale.... je suis tombé dessus par hasard... tu m'as sauvé... merci beaucoup!
Stephan
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une formidable macro de dédoublenage créée par Léo Heuser en y ajouta nt des boites de saisies afin de ne pas avoir à rentrer dans la macro pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la macro originale de Léo Heuser enlève les doublons quand par exemple A et B et F sont identiques (c'est ce que je veux) alors que la modification apportée par AV supprime les doublons par exemple quand A ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B et F et boites de saisies de AV.
'Cette procédure supprime les doublons ou en fait la liste. 'Elle supprime ou inclut dans la liste par lignes entières. 'Une liste des doublons peut être insérée dans une nouvelle feuille 'après la feuille active. Les numéros de lignes peuvent être ajoutés à la liste. 'Plus d'une colonne peut être utilisée pour trouver 'les doublons de la liste. Par exemple, la colonne A peut 'contenir plusieurs entrées avec le nom "Peter" 'la colonne B plusieurs entrées avec "Smith", 'la colonne F plusieurs entrées avec "Oxford St." 'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F") 'va inclure dans la liste ou supprimer tous les doublons où 'une correspondance existe entre "A" *et* "B" *et* "F" ' A B F '1 Name Surname Address '2 Peter Smith Oxford St. '3 Peter Smith Regent St. '4 Peter Jones Oxford St. '5 Peter Smith Oxford St. 'Avec ces contraintes, seule la 5ème ligne est considérée 'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour 'les paramètres de travail de la macro 'Set CheckRows = Rows("1:1000") 'ColumnsToMatch = Array("A", "B", "C") 'DeleteDuplicates = False 'FormatDuplicates = False 'WriteListOfDuplicates = True 'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites p ar AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "") 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
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
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
leo.heu !!!Ta macro de dédoublonnage est trop géniale.... je suis
tombé dessus par hasard... tu m'as sauvé... merci beaucoup!
Stephan
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une
formidable macro de dédoublenage créée par Léo Heuser en y ajouta nt
des boites de saisies afin de ne pas avoir à rentrer dans la macro
pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la
macro originale de Léo Heuser enlève les doublons quand par exemple
A et B et F sont identiques (c'est ce que je veux) alors que la
modification apportée par AV supprime les doublons par exemple quand A
ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le
meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B
et F et boites de saisies de AV.
Sub DuplicatesInList()
'leo.heuser@get2net.dk, August 17, 2001
'Cette procédure supprime les doublons ou en fait la liste.
'Elle supprime ou inclut dans la liste par lignes entières.
'Une liste des doublons peut être insérée dans une nouvelle feuille
'après la feuille active. Les numéros de lignes peuvent être
ajoutés à la liste.
'Plus d'une colonne peut être utilisée pour trouver
'les doublons de la liste. Par exemple, la colonne A peut
'contenir plusieurs entrées avec le nom "Peter"
'la colonne B plusieurs entrées avec "Smith",
'la colonne F plusieurs entrées avec "Oxford St."
'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F")
'va inclure dans la liste ou supprimer tous les doublons où
'une correspondance existe entre "A" *et* "B" *et* "F"
' A B F
'1 Name Surname Address
'2 Peter Smith Oxford St.
'3 Peter Smith Regent St.
'4 Peter Jones Oxford St.
'5 Peter Smith Oxford St.
'Avec ces contraintes, seule la 5ème ligne est considérée
'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
'Set CheckRows = Rows("1:1000")
'ColumnsToMatch = Array("A", "B", "C")
'DeleteDuplicates = False
'FormatDuplicates = False
'WriteListOfDuplicates = True
'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites p ar
AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "")
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
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
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
leo.heu !!!Ta macro de dédoublonnage est trop géniale.... je suis tombé dessus par hasard... tu m'as sauvé... merci beaucoup!
Stephan
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une formidable macro de dédoublenage créée par Léo Heuser en y ajouta nt des boites de saisies afin de ne pas avoir à rentrer dans la macro pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la macro originale de Léo Heuser enlève les doublons quand par exemple A et B et F sont identiques (c'est ce que je veux) alors que la modification apportée par AV supprime les doublons par exemple quand A ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B et F et boites de saisies de AV.
'Cette procédure supprime les doublons ou en fait la liste. 'Elle supprime ou inclut dans la liste par lignes entières. 'Une liste des doublons peut être insérée dans une nouvelle feuille 'après la feuille active. Les numéros de lignes peuvent être ajoutés à la liste. 'Plus d'une colonne peut être utilisée pour trouver 'les doublons de la liste. Par exemple, la colonne A peut 'contenir plusieurs entrées avec le nom "Peter" 'la colonne B plusieurs entrées avec "Smith", 'la colonne F plusieurs entrées avec "Oxford St." 'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F") 'va inclure dans la liste ou supprimer tous les doublons où 'une correspondance existe entre "A" *et* "B" *et* "F" ' A B F '1 Name Surname Address '2 Peter Smith Oxford St. '3 Peter Smith Regent St. '4 Peter Jones Oxford St. '5 Peter Smith Oxford St. 'Avec ces contraintes, seule la 5ème ligne est considérée 'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour 'les paramètres de travail de la macro 'Set CheckRows = Rows("1:1000") 'ColumnsToMatch = Array("A", "B", "C") 'DeleteDuplicates = False 'FormatDuplicates = False 'WriteListOfDuplicates = True 'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites p ar AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "") 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
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
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
Ange Ounis
Remplace ces lignes de code :
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))
Par celles-ci :
S = InputBox("Colonnes à examiner (utiliser cette notation : ""A"",""F"") :") ColumnsToMatch = Array(S) Set CheckRows = Rows(lgDéb & ":" & lgFin)
---------- Ange Ounis ----------
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une formidable macro de dédoublenage créée par Léo Heuser en y ajoutant des boites de saisies afin de ne pas avoir à rentrer dans la macro pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la macro originale de Léo Heuser enlève les doublons quand par exemple A et B et F sont identiques (c'est ce que je veux) alors que la modification apportée par AV supprime les doublons par exemple quand A ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B et F et boites de saisies de AV.
'Cette procédure supprime les doublons ou en fait la liste. 'Elle supprime ou inclut dans la liste par lignes entières. 'Une liste des doublons peut être insérée dans une nouvelle feuille 'après la feuille active. Les numéros de lignes peuvent être ajoutés à la liste. 'Plus d'une colonne peut être utilisée pour trouver 'les doublons de la liste. Par exemple, la colonne A peut 'contenir plusieurs entrées avec le nom "Peter" 'la colonne B plusieurs entrées avec "Smith", 'la colonne F plusieurs entrées avec "Oxford St." 'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F") 'va inclure dans la liste ou supprimer tous les doublons où 'une correspondance existe entre "A" *et* "B" *et* "F" ' A B F '1 Name Surname Address '2 Peter Smith Oxford St. '3 Peter Smith Regent St. '4 Peter Jones Oxford St. '5 Peter Smith Oxford St. 'Avec ces contraintes, seule la 5ème ligne est considérée 'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour 'les paramètres de travail de la macro 'Set CheckRows = Rows("1:1000") 'ColumnsToMatch = Array("A", "B", "C") 'DeleteDuplicates = False 'FormatDuplicates = False 'WriteListOfDuplicates = True 'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites par AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "") 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
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
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
Remplace ces lignes de code :
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))
Par celles-ci :
S = InputBox("Colonnes à examiner (utiliser cette notation : ""A"",""F"") :")
ColumnsToMatch = Array(S)
Set CheckRows = Rows(lgDéb & ":" & lgFin)
----------
Ange Ounis
----------
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une
formidable macro de dédoublenage créée par Léo Heuser en y ajoutant
des boites de saisies afin de ne pas avoir à rentrer dans la macro
pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la
macro originale de Léo Heuser enlève les doublons quand par exemple
A et B et F sont identiques (c'est ce que je veux) alors que la
modification apportée par AV supprime les doublons par exemple quand A
ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le
meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B
et F et boites de saisies de AV.
Sub DuplicatesInList()
'leo.heuser@get2net.dk, August 17, 2001
'Cette procédure supprime les doublons ou en fait la liste.
'Elle supprime ou inclut dans la liste par lignes entières.
'Une liste des doublons peut être insérée dans une nouvelle feuille
'après la feuille active. Les numéros de lignes peuvent être
ajoutés à la liste.
'Plus d'une colonne peut être utilisée pour trouver
'les doublons de la liste. Par exemple, la colonne A peut
'contenir plusieurs entrées avec le nom "Peter"
'la colonne B plusieurs entrées avec "Smith",
'la colonne F plusieurs entrées avec "Oxford St."
'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F")
'va inclure dans la liste ou supprimer tous les doublons où
'une correspondance existe entre "A" *et* "B" *et* "F"
' A B F
'1 Name Surname Address
'2 Peter Smith Oxford St.
'3 Peter Smith Regent St.
'4 Peter Jones Oxford St.
'5 Peter Smith Oxford St.
'Avec ces contraintes, seule la 5ème ligne est considérée
'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour
'les paramètres de travail de la macro
'Set CheckRows = Rows("1:1000")
'ColumnsToMatch = Array("A", "B", "C")
'DeleteDuplicates = False
'FormatDuplicates = False
'WriteListOfDuplicates = True
'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites par
AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "")
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
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
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
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))
Par celles-ci :
S = InputBox("Colonnes à examiner (utiliser cette notation : ""A"",""F"") :") ColumnsToMatch = Array(S) Set CheckRows = Rows(lgDéb & ":" & lgFin)
---------- Ange Ounis ----------
Bonjour:
Il y a quelques années AV m'avait très gentillement adapté une formidable macro de dédoublenage créée par Léo Heuser en y ajoutant des boites de saisies afin de ne pas avoir à rentrer dans la macro pour modifier les variables.
En reprenant cette macro (voir ci-dessous), je me rend compte que la macro originale de Léo Heuser enlève les doublons quand par exemple A et B et F sont identiques (c'est ce que je veux) alors que la modification apportée par AV supprime les doublons par exemple quand A ou B ou F sont identiques.
Quelqu'un pourrait-il me dire ou est le problème car je voudrais le meilleur des deux mondes macro dédoublonnage de Leo Heuser type A et B et F et boites de saisies de AV.
'Cette procédure supprime les doublons ou en fait la liste. 'Elle supprime ou inclut dans la liste par lignes entières. 'Une liste des doublons peut être insérée dans une nouvelle feuille 'après la feuille active. Les numéros de lignes peuvent être ajoutés à la liste. 'Plus d'une colonne peut être utilisée pour trouver 'les doublons de la liste. Par exemple, la colonne A peut 'contenir plusieurs entrées avec le nom "Peter" 'la colonne B plusieurs entrées avec "Smith", 'la colonne F plusieurs entrées avec "Oxford St." 'Passer à l'argument ColumnsToMatch la valeur Array("A", "B", "F") 'va inclure dans la liste ou supprimer tous les doublons où 'une correspondance existe entre "A" *et* "B" *et* "F" ' A B F '1 Name Surname Address '2 Peter Smith Oxford St. '3 Peter Smith Regent St. '4 Peter Jones Oxford St. '5 Peter Smith Oxford St. 'Avec ces contraintes, seule la 5ème ligne est considérée 'comme un doublon. (trad. fs)
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
'adapter les 6 variables ci-dessous pour mettre à jour 'les paramètres de travail de la macro 'Set CheckRows = Rows("1:1000") 'ColumnsToMatch = Array("A", "B", "C") 'DeleteDuplicates = False 'FormatDuplicates = False 'WriteListOfDuplicates = True 'AddRowNumberToList = True
'les lignes suivantes définissant les input box ont été écrites par AV sur MPFE (ajouté par Christophe Joly)
lgDéb = InputBox("Input first row number e.g. 1", "") 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
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
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
