Macro complémentaire de dédoublonnage pour excel

Télécharger le projet
Commenter

Description

Cette macro permet de dédoublonner une base excel en fonction de colonnes ou en-têtes de colonnes choisies par l'utilisateur.
Le classeur contient :
  • un menu "Dédoublonnage" qui se met en place à l'ouverture (permettant de choisir le dédoublonnage en prenant en compte ou non la première ligne),
  • un formulaire de selection permettant de sélectionner la ou les colonnes à prendre en compte et de choisir l'ordre dans lequel les colonnes seront triées, (il est autonome et peut être utilisé dans un autre projet)
  • du code VBA dont le code servant au dédoublonnage (dans le module "Dedoublonnage") présenté ci-après peut être inclu dans un autre projet.

Source / Exemple : 


'*********************************************************
' 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

Conclusion :


Prochainement, présentation du module "Assistant" de cette source.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (sybacs)