Doublons multicolonnes

Dim C As Long           'Au lieu de Dim C As Integer

Cliquez pour agrandir...

Private Sub btnDoublons_Click()
Dim TabTemp As Variant, TabTemp2() As Variant
Dim Db As New Collection
Dim L As Long, L2 As Long, C As Long
Dim Ndb As Long, Nsel As Long
Dim Nc As Integer
Dim T As String
Application.ScreenUpdating = False
With ActiveSheet
      'Dernière ligne utilisée
      L = .Range('A1').SpecialCells(xlLastCell).Row
      'Dernière colonne utilisée
      C = .Range('A1').SpecialCells(xlLastCell).Column
      If L = 1 And C = 1 Then Exit Sub
      'Mémoriser les données dans un tableau variant temporaire
      TabTemp = .Range(.Cells(1, 1), .Cells(L, C)).Value
      ReDim TabTemp2(UBound(TabTemp, 1), 2)
      'Concaténer les colonnes de données dans un tableau variant temporaire
      For L = 1 To UBound(TabTemp, 1)
            For Nc = 0 To lstColmDF.ListCount - 1
                  If Nc >= C Then Exit For
                  If lstColmDF.Selected(Nc) Then
                        TabTemp2(L, 1) = TabTemp2(L, 1) & CStr(TabTemp(L, Nc + 1))
                  End If
            Next Nc
      Next L
      'Détecter les doublons (d'après méthode de J.Walkenbach basée sur une astuce de J.G. Hussey)
      .Cells(1, 1).Select
      On Error Resume Next
      For L = 1 To UBound(TabTemp2, 1)
            If TabTemp2(L, 1) <> '' Then
                  Db.Add TabTemp2(L, 1), CStr(TabTemp2(L, 1))
                  If Db.Count = Ndb Then
                        If Selection.Count = 1 Then .Rows(L).Select
                        Union(Selection, .Rows(L)).Select
                        Nsel = Nsel + 1
                        'Sélectionne également la première occurence
                        For L2 = 1 To L
                              If Application.Intersect(.Cells(L2, 1), Selection) Is Nothing Then
                                    If TabTemp2(L2, 1) = TabTemp2(L, 1) Then
                                          Union(Selection, .Rows(L2)).Select
                                          Nsel = Nsel + 1
                                          Exit For
                                    End If
                              End If
                        Next L2
                  Else
                        Ndb = Ndb + 1
                  End If
            End If
      Next L
      On Error GoTo 0
      Me.Hide
      Application.ScreenUpdating = True
      If C > 0 Then
            T = IIf(chkArchive, ' de cette feuille et archivées dans un nouvel onglet ''Doublons'' !', ' !')
            If MsgBox(Nsel & ' lignes seront supprimées' & T & vbCrLf & vbCrLf & 'Souhaitez-vous ' _
                  & 'continuer ?', vbQuestion + vbYesNo + vbDefaultButton2, 'myDearFriend!') = vbYes Then
                  If chkArchive Then Archive
                  Selection.Delete
            End If
      Else
            MsgBox 'Aucun doublon trouvé !', vbOKOnly + vbInformation, 'myDearFriend!'
      End If
End With
Unload Me
End Sub

Cliquez pour agrandir...