Supprimer des doublons

[piep14]

Bonsoir,

J'ai un tableau avec pleins de valeurs. Certaines lignes sont totalement identique et je voudrais les supprimer grâce à une fonction que je ne sais guère faire :S Pourriez vous me filer un coup de pouce 😉

Je prend l'exemple des premières lignes.
On compare les colonnes de A à H, si tout est exactement identique, on supprime la ligne ne contenant rien dans la colonne I. Bien sur, si rien dans I sur les deux lignes, on supprime une des deux.

Je vous remercie d'avance, ceci est très important 😉

.:: Partage-facile.com ::. La simplicité du partage de fichiers

Grand merci

 

[roro69]

Re : Supprimer des doublons

Bonsoir essaye ce petit code
Sub Doublon()
Dim cellulecourante As Range
Dim cellulesuivante As Range
Set cellulecourante = ActiveSheet.Range("A1")


ActiveSheet.Range("A2").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


Do While Not IsEmpty(cellulecourante) = True
Set cellulesuivante = cellulecourante.Offset(1, 0)
If cellulesuivante.Value = cellulecourante.Value Then
If Lignesidentiques(cellulecourante, cellulesuivante) = True Then
MsgBox "Doublon"
cellulecourante.EntireRow.Delete
End If
End If
Set cellulecourante = cellulesuivante
Loop
End Sub
////////////////////////////////////////////////////////////////////////////////////
Function Lignesidentiques(cellulecourante As Range, cellulesuivante As Range) As Boolean
If cellulecourante.Offset(0, 1).Value <> cellulesuivante.Offset(0, 1).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 2).Value <> cellulesuivante.Offset(0, 2).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 3).Value <> cellulesuivante.Offset(0, 3).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 4).Value <> cellulesuivante.Offset(0, 4).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 5).Value <> cellulesuivante.Offset(0, 5).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 6).Value <> cellulesuivante.Offset(0, 6).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 7).Value <> cellulesuivante.Offset(0, 7).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 8).Value <> cellulesuivante.Offset(0, 8).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 9).Value = "" Then
Lignesidentiques = False
Else
Lignesidentiques = True
End If
End Function

 

[piep14]

Re : Supprimer des doublons

Ton code marche bien, j'aimerais apporter encore de nouveau trucs pour continuer mon tri.

Je prend l'exemple des premières lignes.
On compare les colonnes de A à H, si deux lignes (voire plus) sont identiques sauf la colonne H, on remplit les cellules d'une couleur.

Et après ca sera parfait (enfin, je crois lol)

Merci mille fois

 

[roro69]

Re : Supprimer des doublons

Re;Essaye ceci

Sub Doublon()
Dim cellulecourante As Range
Dim cellulesuivante As Range
Set cellulecourante = ActiveSheet.Range("A1")


ActiveSheet.Range("A2").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


Do While Not IsEmpty(cellulecourante) = True
Set cellulesuivante = cellulecourante.Offset(1, 0)
If cellulesuivante.Value = cellulecourante.Value Then
If Lignesidentiques(cellulecourante, cellulesuivante) = True Then
MsgBox "Doublon"
Cell.Interior.ColorIndex = 43
End If
End If
Set cellulecourante = cellulesuivante
Loop
End Sub
/////////////////////////////////////////////////////////////////////////////////////////
Function Lignesidentiques(cellulecourante As Range, cellulesuivante As Range) As Boolean
If cellulecourante.Offset(0, 1).Value <> cellulesuivante.Offset(0, 1).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 2).Value <> cellulesuivante.Offset(0, 2).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 3).Value <> cellulesuivante.Offset(0, 3).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 4).Value <> cellulesuivante.Offset(0, 4).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 5).Value <> cellulesuivante.Offset(0, 5).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 6).Value <> cellulesuivante.Offset(0, 6).Value Then
Lignesidentiques = False
ElseIf cellulecourante.Offset(0, 7).Value <> cellulesuivante.Offset(0, 7).Value Then
Lignesidentiques = False

Else
Lignesidentiques = True
End If
End Function

 

[piep14]

Re : Supprimer des doublons

Ca semble pas fonctionner, ca met "objet requis" puis rien

 

[piep14]

Re : Supprimer des doublons

C'est a ce niveau ci semble t'il :
Cell.Interior.ColorIndex = 43

 

[roro69]

Re : Supprimer des doublons

RE Remplace
Cell.Interior.ColorIndex = 43
par
cellulecourante.Interior.ColorIndex = 43

 

[piep14]

Re : Supprimer des doublons

Pourquoi je vois encore :

8000012155 65 120 FS415 2504155-7 SPACER N/A 35 8000012155 65 120 FS415 2504155-7 SPACER N/A 35 8000012155 65 120 FS415 2504155-7 SPACER REP-TPLAB120 2 8000012155 65 120 FS415 2504155-7 SPACER REP-TPLAB120 2

Alors que ce sont des doublons ?