Gestion des doublons par macro

[biddal]

Bonjour,
Alors j'ai 3 fichiers différents Perf1, Perf2 et Rslt.
J'ai une macro dans Rslt qui me copie les données provenant des 2 tableaux identiques des fichiers Perf1 et Perf2 (juste les performances et le nom des sportifs changent, l'intitulé des colonnes sont les mêmes).
Tout cela fonctionne correctement!
Voici le code que j'ai :

Sub Bouton1_QuandClic()

Dim LigneCopiageFin As Long
Dim LigneCollage As Long
Dim LigneCopiageFin2 As Long
Dim LigneCollage2 As Long

'Traitement du Fichier 1 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Workbooks.Open Filename:="C:\Documents and Settings\bdu\Bureau\Excel_FSI\Perf1.xls"

LigneCopiageFin = Range("A65535").End(xlUp).Row
Range("A2:G" & LigneCopiageFin).Copy

Windows("Rslt.xls").Activate

LigneCollage = Range("A65535").End(xlUp).Row
LigneCollage = LigneCollage + 1

Range("A" & LigneCollage).Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
  
' Traitement du Fichier 2 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Workbooks.Open Filename:="C:\Documents and Settings\bdu\Bureau\Excel_FSI\Perf2.xls"

LigneCopiageFin2 = Range("A65535").End(xlUp).Row
Range("A2:G" & LigneCopiageFin2).Copy

Windows("Rslt.xls").Activate

LigneCollage2 = Range("A65535").End(xlUp).Row
LigneCollage2 = LigneCollage2 + 1

Range("A" & LigneCollage2).Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 
' Fermeture des différents fichiers excel sauf celui de la macro '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim n As Integer

n = Workbooks.Count
MsgBox "Il y a " & n & " fichier(s) excel ouvert "
Do Until Workbooks.Count = 1
If Not Workbooks(n).Name = ActiveWorkbook.Name Then Workbooks(n).Close
n = n - 1
Loop

End Sub

Ce que je souhaite maintenant c'est géré les doublons. Mais là je souhaite encore quelque chose de bien précis! En fait les doublons entre Perf1 et Perf2 sont impossible normalement donc je ne vais pas le gérer pour l'instant je verais plus tard ça.

Dans le fonctionnement de ma macro en fait je copie/colle l'intégralité du tableau à chaque fois.
Ex:
Le lundi je lance ma macro il va me copier tout le tableau de Perf1 et celui de Perf2 dans le Rslt
Le mardi après quelques ajouts, je relance cette macro et là je vais recopier encore l'intégralité des 2 tableaux de Perf1 et Perf2 à la suite dans le fichier Rslt!
Et c'est là que ça pose problème je souhaiterais que ma macro avant de coller fasse une recherche de doublon! Si le nom de la personne existe déjà et bien on ne l'ajoute pas à Rslt sauf si la date est plus récente!
Je ne sais pas si mes explications sont assez claires! N'hésitez pas si vous avez besoin de renseignements particuliers pour comprendre ce que je souhaite faire. (Je sais déjà que ma macro actuelle n'est pas optimisée mais elle fonctionne )
Je joins mes 3 fichiers pour l'exemple.
Merci par avance.

 

[Guest]

Re : Gestion des doublons par macro

Bonsoir,

Voici un module qui contient 1 macro et une fonction
La première se charge d'ouvrir les fichiers, d'appeler la fonction de mise à jour et de refermer les fichiers.

La fonction cherche si un nom existe.
S'il existe, compare les dates de mise à jour et change les données de la ligne si la source est plus récente
sinon elle place les données en fin de tableau.
Elle retourne le nombre de ligne mises à jour

[COLOR=blue]Sub[/COLOR] Bouton1_QuandClic()
    [COLOR=blue]Dim[/COLOR] WkbSource [COLOR=blue]As[/COLOR] Workbook
    [COLOR=blue]Dim[/COLOR] Root [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR]
    [COLOR=blue]Dim[/COLOR] cpt [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
    [COLOR=blue]Dim[/COLOR] msg [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR]
    [COLOR=blue]Dim[/COLOR] i [COLOR=blue]As[/COLOR] [COLOR=blue]Integer[/COLOR]
    [COLOR=green]'Mettre le répertoire initial des classeurs sources[/COLOR]
    Root = ThisWorkbook.Path & [I]"\"[/I]
 
    [COLOR=blue]For[/COLOR] i = 1 To 2
        [COLOR=green]'Ouvrir un fichier[/COLOR]
        [COLOR=blue]Set[/COLOR] WkbSource = Workbooks.[COLOR=blue]Open[/COLOR](Filename:=Root & [I]"\Perf"[/I] & i & [I]".xls"[/I])
        [COLOR=blue]With[/COLOR] WkbSource.Sheets([I]"Feuil1"[/I])
            [COLOR=green]'Appeler la fonction de mise à jour et retourner le nombre de lignes mises à jour[/COLOR]
            [COLOR=green]'En paramètre passer la plage qui contient les noms (colonne A)[/COLOR]
            cpt = MiseAJourDatas(.Range([I]"A2:A"[/I] & .Range([I]"A"[/I] & Rows.Count).[COLOR=blue]End[/COLOR](xlUp).Row))
            msg = cpt & [I]" ligne(s) mise(s) à jour à partir du fichier: '"[/I] & WkbSource.Name
        [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
        [COLOR=green]'Fermeture du fichier[/COLOR]
        WkbSource.[COLOR=blue]Close[/COLOR]
 
        [COLOR=green]'affichage du message du nombre de lignes mises à jour[/COLOR]
        MsgBox msg, vbInformation, [I]"Mise à jour résultats"[/I]
    [COLOR=blue]Next[/COLOR]
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]
[COLOR=blue]Function[/COLOR] MiseAJourDatas(Plage [COLOR=blue]As[/COLOR] Range) [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
    [COLOR=blue]Dim[/COLOR] cSource [COLOR=blue]As[/COLOR] Range, cDest [COLOR=blue]As[/COLOR] Range
    [COLOR=blue]Dim[/COLOR] cpt [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
    [COLOR=green]'Travailler sur la feuille de destination[/COLOR]
    [COLOR=blue]With[/COLOR] ThisWorkbook.Sheets([I]"Feuil1"[/I])
        [COLOR=green]'Pour chaque cellule de la plage source[/COLOR]
        [COLOR=blue]For[/COLOR] [COLOR=blue]Each[/COLOR] cSource [COLOR=blue]In[/COLOR] Plage.Cells
            [COLOR=green]'Chercher dans la feuille destination si le nom existe[/COLOR]
            [COLOR=blue]Set[/COLOR] cDest = .Range([I]"A:A"[/I]).Find(what:=cSource, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=[COLOR=blue]False[/COLOR])
            [COLOR=blue]If[/COLOR] cDest [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR]
                [COLOR=green]'Le nom n'existe pas [COLOR=blue]on[/COLOR] ajoute les donnée sur la prochaine ligne disponible[/COLOR]
                .Range([I]"A"[/I] & .Rows.Count).[COLOR=blue]End[/COLOR](xlUp).Offset(1).Resize(, 8).Value = cSource.Resize(, 8).Value
                cpt = cpt + 1
            [COLOR=blue]Else[/COLOR]
                [COLOR=green]'Le nom existe déjà, comparer les dates[/COLOR]
                [COLOR=green]'si la [COLOR=blue]date[/COLOR] de dernière mise à jour est inferieur à la [COLOR=blue]date[/COLOR] source[/COLOR]
                [COLOR=blue]If[/COLOR] cDest.Offset(, 7).Value < cSource.Offset(, 7).Value [COLOR=blue]Then[/COLOR]
                    [COLOR=green]'Alors [COLOR=blue]on[/COLOR] copie les données[/COLOR]
                    cDest.Resize(, 8).Value = cSource.Resize(, 8).Value
                [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
                cpt = cpt + 1
            [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
        [COLOR=blue]Next[/COLOR]
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
    MiseAJourDatas = cpt
[COLOR=blue]End[/COLOR] [COLOR=blue]Function[/COLOR]

A+

[Edit]Mince David_xld, j'ai oublié le [AÏEL'AIL] Promis je teste la prochaine fois.

 

[biddal]

Re : Gestion des doublons par macro

Bonjour,
Merci beaucoup pour ta réponse ça fonctionne nikel !! Désolé de ne pas avoir répondu avant mais j'étais très occupé et je n'ai pas eu le temps de me repencher sur le problème !!
Vraiment merci et bonne journée !