Macro complémentaire de dédoublonnage pour excel

Soyez le premier à donner votre avis sur cette source.

Vue 38 238 fois - Téléchargée 11 133 fois

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.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
4
Date d'inscription
jeudi 27 mai 2004
Statut
Membre
Dernière intervention
23 octobre 2010

Merci pour ce code, il fonctionne super Bien
Bravo à toi

Oli
Messages postés
1
Date d'inscription
vendredi 8 août 2003
Statut
Membre
Dernière intervention
17 janvier 2009

excellent comme procédure associé au formulaire.
Terminé les NB.SI ou les IF then.

Merci à toi sybacs
Messages postés
2
Date d'inscription
lundi 10 juin 2002
Statut
Membre
Dernière intervention
8 décembre 2008

Thibault,

Si la cellule A1 est vide, le dédoublonnage ne s'effectue pas.
Les entêtes doivent se situer en ligne 1 (à partir de colonne A) s'il y en a. S'il n'y a pas d'entête la première ligne à dédoublonner doit être en ligne 1)

Sylvain
Messages postés
4
Date d'inscription
lundi 28 janvier 2008
Statut
Membre
Dernière intervention
7 décembre 2008

Bonjour, je n'arrive pas à l'utiliser. Je l'ai installé sur Excel 2003, je vois bien le nouveau menu mais qd je clique sur entête ou colonne, il ne se passe rien du tout : aucun formulaire n'apparait.
Que faut-il faire ?

MErci
Thibault
Messages postés
1
Date d'inscription
mardi 21 novembre 2006
Statut
Membre
Dernière intervention
29 octobre 2007

Salut,

j'ai testé ton code, parce que j'ai une macro qui importe environ 600 lignes de données et checher les doublons peut s'avérer tres difficile.

je trouve qu'il est très bien fait, merci de nous faire partager ces infos.

Cdt

Sony
Afficher les 6 commentaires

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.