MACRO COMPLÉMENTAIRE DE DÉDOUBLONNAGE POUR EXCEL

'*********************************************************
' Une partie du code qui peut être utilisée séparément   *
' avec un exemple d'utilisation                          *
'*********************************************************
Sub Exemple()
'Pour inséere cette macro à un autre projet copier ce module
'appeler la procédure suivante
'Dedoublonnage(ListCol, LigneEnTete)
'ListCol : tableau contenant les numéros de colonne
'          si une seule colonne x utiliser quand-même un tableau : array(x)
'LigneEnTete : True si la première ligne est une ligne d'entête
'               False s 'il n'y a pas de ligne d'entête
'L'exemple suivant fait le dédoublonnage sur les colonnes 1 et 3
'la première ligne étant l'entête
'La première clé de tri est la colonne 1 et la seconde la colonne 3
Call Dedoublonnage(Array(1, 3), True)
End Sub
Sub ProcDedoublonnage(ListCol, LigneEnTete) 'LigneEnTete = True ou False
    Cells(1, 1).Select
    ListCol2 = IntervertionTab(ListCol)
    If LigneEnTete Then
        NumLig = 2
    Else
        NumLig = 1
    End If

    NoLgnFin = ActiveSheet.UsedRange.Rows.Count
    NoColFin = ActiveSheet.UsedRange.Columns.Count
    Min = LBound(ListCol2)
    Max = UBound(ListCol2)
    ReDim TabTest1(Max - Min)
    ReDim TabTest2(Max - Min)
    For I = Min To Max
        Call TriTab(ListCol2(I), NumLig)
    Next I
    ' Tag des Doublons
    For Ligne = NumLig To NoLgnFin - 1
        CptColTest = Min
        For CptTabTest = LBound(TabTest1) To UBound(TabTest1)
            TabTest1(CptTabTest) = Cells(Ligne, ListCol2(CptColTest))
            TabTest2(CptTabTest) = Cells(Ligne + 1, ListCol2(CptColTest))
            CptColTest = CptColTest + 1
        Next CptTabTest
    VarEstDoublon = EstDoublon(TabTest1, TabTest2)
    If VarEstDoublon Then
    Cells(Ligne + 1, NoColFin + 1).Value = "Doublon"
    Mini1Doublon = True
    End If
    Next Ligne
    ' Suppression des doublons
        If Mini1Doublon Then
            Call TriTab(NoColFin + 1, NumLig)
            LigDoub = NumLig
            Do While Cells(LigDoub + 1, NoColFin + 1).Value = "Doublon"
                LigDoub = LigDoub + 1
            Loop
        Range(Cells(NumLig, NoColFin + 1), Cells(LigDoub, NoColFin + 1)).EntireRow.Delete 'Select
        End If
End Sub
Sub TriTab(NumCol, NumLig)
    If NumLig = 2 Then
        Entete = xlYes
    Else
        Entete = xlGuess
    End If
    Selection.Sort Key1:=Cells(NumLig, NumCol), Order1:=xlAscending, Header:=Entete, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Function EstDoublon(Tab1, Tab2)
    EstDoublon = True
    NbChamp = UBound(Tab1)
    If NbChamp = UBound(Tab2) Then
    I = 0
        Do
            If Tab1(I) <> Tab2(I) Then
                EstDoublon = False
            End If
            I = I + 1
        Loop While EstDoublon = True And I <= NbChamp
    Else
        EstDoublon = False
    End If
End Function
Function IntervertionTab(Tableau)
    Min = LBound(Tableau)
    Max = UBound(Tableau)
    Nb = (Max - Min + 1) \ 2
    For I = Min To Nb - 1 + Min
        VarIntermed = Tableau(I)
        Tableau(I) = Tableau(Max - I + Min)
        Tableau(Max - I + Min) = VarIntermed
    Next I
    IntervertionTab = Tableau
End Function

Télécharger le zip

20 mars 2006 17:49:26 :

Modification de l'exemple.

20 mars 2006 18:02:31 :

Suppression d'une ligne de code en double (deux fois le même tri)

22 mars 2006 10:48:00 :

Correction d'un bug (une ligne avait été placée en commentaire pour test) Ajout de deux boutons sur le formulaire : tout selectionner et tout déselectionner.