1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
| Sub Extrairelesdoublons()
Dim f1 As Worksheet
Dim i As Long, DerLig_D As Long, DerLig_E As Long, DerLig_F As Long, DerLig_G As Long
Dim Valeur As String
Dim C As Object
Set f1 = Sheets("Calcule")
Application.ScreenUpdating = False
DerLig_D = f1.[D100000].End(xlUp).Row
For i = 3 To DerLig_D
Valeur = f1.Cells(i, "D")
Set C = f1.Columns("A:C").Find(Valeur, LookIn:=xlValues, lookat:=xlWhole)
If Not C Is Nothing Then
If C.Column = 1 Then
DerLig_E = f1.[E100000].End(xlUp).Row
f1.Cells(DerLig_E + 1, "E") = f1.Cells(C.Row, "A")
f1.Cells(C.Row, "A").Delete
ElseIf C.Column = 2 Then
DerLig_F = f1.[F100000].End(xlUp).Row
f1.Cells(DerLig_F + 1, "F") = f1.Cells(C.Row, "B")
f1.Cells(C.Row, "B").Delete
ElseIf C.Column = 3 Then
DerLig_G = f1.[G100000].End(xlUp).Row
f1.Cells(DerLig_G + 1, "G") = f1.Cells(C.Row, "C")
f1.Cells(C.Row, "C").Delete
End If
End If
Next i
Set f1 = Nothing
Set C = Nothing
End Sub |
Partager