Supprimer doublons
m
Bonjour à tous,
J'ai un début de code pour surligner en rouge les doublons dans 2 feuilles différentes.
Je souhaite mettre en rouge les lignes qui sont en double dans la feuille 1
Feuille 1 onglet 1 : Yq_ProgressBackupWP3 (Comparer colonnes F, J, S et G)
Feuille 2 onglet 1 : Missing_Documents (Comparer colonnes F,J,S et G)
Début de code mais j'ai l'impression que ce n'est pas très fiable :
Private Sub CommandButton4_Click()
Dim Cel As Range
Dim Kase As Range
Dim i As Integer
Dim col_2 As Range
Dim col_3 As Range
Dim col_4 As Range
Dim col_5 As Range
Application.ScreenUpdating = False
If SelectionErreur = True Then Exit Sub
With Sheets("Yq_ProgressBackupWP3")
.Cells.Font.ColorIndex = xlAutomatic
If Application.Subtotal(103, .Columns("F")) > 1 Then
For Each Kase In .Range("G2:G" & NbLgYq).SpecialCells(xlCellTypeVisible)
Debug.Print Kase.Address, Kase
Set Cel = Sheets("Missing_Documents").Columns("F").Find(What:=Kase, LookIn:=xlValues, LookAt:=xlWhole)
Set col_2 = Worksheets("Missing_Documents").Range("F2:F1000")
Set col_3 = Worksheets("Missing_Documents").Range("J2:J1000")
Set col_4 = Worksheets("Missing_Documents").Range("S2:S1000")
Set col_5 = Worksheets("Missing_Documents").Range("G2:G1000")
For i = 1000 To 2 Step -1
If Application.CountIf(col_2, .Range("F" & i).Value) = 0 Then
If Application.CountIf(col_3, .Range("J" & i).Value) = 0 Then
If Application.CountIf(col_4, .Range("S" & i).Value) = 0 Then
If Application.CountIf(col_5, .Range("G" & i).Value) = 0 Then
.Rows(i).Interior.ColorIndex = 3 'Rouge
End If
End If
End If
End If
Next i
Next Kase
End If
.Select
End With
End Sub
Est-ce que l'un d'entre vous peut m'aider ?
Merci beaucoup