Supprimer doublons

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

Rechercher des sujets similaires à "supprimer doublons"