suppression doublons automatique

B

bonjourdoc

XLDnaute Nouveau
Bonjour,

J'ai trouvé, en naviguant sur divers forums, une macro qui me permet de réunir plusieurs fichiers excel en un seul (que j'ai appelé "global.xls"), et ceci, dès l'ouverture de "global.xls".

Mon fichier global contient une liste de gens faisant des pré-réservations de matériel dans une médiathèque. Cette liste s'agrandit chaque jour. Elle est donc assez longue.
Une ligne de ma liste contient les infos suivantes: nom, prénom, email, code barre, date d'emprunt, date de retour, etc.
bref des infos de la colonne A jusqu'à P.
Mon fichier global contient des doublons. J'appelle doublons des lignes exactement identiques, de A à P.
Je souhaiterais, par une macro, effacer ces doublons et garder un exemplaire unique.
Je souhaiterais aussi que cette macro s'effectue automatiquement à l'ouverture de mon fichier "global.xls".

Merci de me venir en aide.

A.


Voici mon code:
Private Sub Workbook_Open()
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim mxc As Long ' maximum colones feuille
Dim c As Integer ' nombre de colonnes
Dim l As Long ' ligne lecture
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
Set Wf = ThisWorkbook.Sheets("Feuil1") ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets("JU HEP BEJUNE - Médiathèque de ")
nbl = Wl.UsedRange.Rows.Count
c = Wl.UsedRange.Columns.Count
If ligne > 2 Then l = 2 Else l = 1 ' une seule fois le titre
Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
For l = ligne To 2 Step -1
If Wf.Cells(l, mxc).End(xlToLeft).Column = 1 _
And Wf.Cells(l, 1).Value = "" Then
Wf.Rows(l).Delete
ligne = ligne - 1
End If
Next l
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
 
Dernière édition:
Trier par date Trier par votes
Misange

Misange

XLDnaute Barbatruc
Re : suppression doublons automatique

Bonjour

pourquoi passer par une macro ?
Onglet données/supprimer les doublons....
L'enregistreur de macros sur cette fonction te donnera le code à intégrer pour que cela se fase à l'ouverture de ton classeur.
 
Dernière édition:
Vote positif 0 Vote négatif
Misange

Misange

XLDnaute Barbatruc
Re : suppression doublons automatique

entre les deux balises !

Code: 
Private Sub Workbook_Open()
 ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
End Sub

tu adaptes avec le code généré pour l'emplacement de tes données

un peu de lecture ? :)
Ce lien n'existe plus
 
Vote positif 0 Vote négatif
B

bonjourdoc

XLDnaute Nouveau
Re : suppression doublons automatique

Voui!

Je viens de trouver. En fait, il faut placer le code avant le End sub.

Je l'ai placé comme ceci, tout à la fin (ai même ajouté une fonction de tri!).
ça semble fonctionner. Tu peux confirmer, stp?


Private Sub Workbook_Open()
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim mxc As Long ' maximum colones feuille
Dim c As Integer ' nombre de colonnes
Dim l As Long ' ligne lecture
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
Set Wf = ThisWorkbook.Sheets("Feuil1") ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets("JU HEP BEJUNE - Médiathèque de ")
nbl = Wl.UsedRange.Rows.Count
c = Wl.UsedRange.Columns.Count
If ligne > 2 Then l = 2 Else l = 1 ' une seule fois le titre
Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
For l = ligne To 2 Step -1
If Wf.Cells(l, mxc).End(xlToLeft).Column = 1 _
And Wf.Cells(l, 1).Value = "" Then
Wf.Rows(l).Delete
ligne = ligne - 1
End If
Next l
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

' tri_supprimerDoublons Macro
'

'
ActiveWindow.SmallScroll Down:=-102
Range("A2").Select
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange Range("A2:p182")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$P$182").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13, 14, 15, 16), Header:=xlYes
End Sub
 
Vote positif 0 Vote négatif
B

bonjourdoc

XLDnaute Nouveau
Re : suppression doublons automatique

Mmmmh!
Y a un truc qui ne va pas dans mon code.

Code: 
Private Sub Workbook_Open()
Dim chemin As String    ' classeur regroupé
Dim rep As String       ' répertoire à traiter
Dim fic As String       ' classeur regroupé
Dim ligne As Long       ' ligne écriture
Dim nbc As Integer      ' nombre de classeurs
Dim nbf As Integer      ' nombre de feuilles
Dim nbl As Integer      ' nombre de lignes
Dim mxc As Long         ' maximum colones feuille
Dim c As Integer        ' nombre de colonnes
Dim l As Long           ' ligne lecture
Dim Wf As Worksheet     ' feuille regroupement
Dim Wl As Worksheet     ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
Set Wf = ThisWorkbook.Sheets("Feuil1")         ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0                ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls")    ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
    chemin = rep & fic       ' chemin fichiers
        Workbooks.Open chemin, 0  ' ouverture
        Set Wl = ActiveWorkbook.Sheets("JU HEP BEJUNE - Médiathèque de ")
        nbl = Wl.UsedRange.Rows.Count
        c = Wl.UsedRange.Columns.Count
        If ligne > 2 Then l = 2 Else l = 1  ' une seule fois le titre
        Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
        ligne = ligne + nbl - l + 1
        nbf = nbf + 1
        ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
        nbc = nbc + 1
End If
    fic = Dir
Wend
    For l = ligne To 2 Step -1
        If Wf.Cells(l, mxc).End(xlToLeft).Column = 1 _
            And Wf.Cells(l, 1).Value = "" Then
            Wf.Rows(l).Delete
            ligne = ligne - 1
        End If
    Next l
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

' tri_supprimerDoublons Macro
'

'
    ActiveWindow.SmallScroll Down:=-102
    Range("A2").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A2:P182")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$P$182").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16), Header:=xlYes
End Sub

Le début est ok. Mes fichier .xls s'additionnent.
La deuxième partie " tri_supprimerDoublons" n'est pas encore au point.
J'ai donc utilisé l'enregistreur de marco pour effectuer "selectionner tout" > trier A-Z > supprimer les doublons.

2 problèmes:

J'ai effectué cet enregistrement de macro lorsque j'avais compilé 8 fichiers .xls comptant 182 lignes.
Lorsque j'ai ajouté un 9e et un 10e fichier, tout n'était pas pris en compte pour le " tri_supprimerDoublons", puisque celui-ci s'exécutait jusqu'à la ligne 182.
Et comme ma macro prend en compte 182 lignes, mes fichiers 9 et 10 viennent s'ajouter dès la ligne 183.

D'autres fichiers s'ajoutent chaque jour.

Mon but est que ma macro " tri_supprimerDoublons" prenne d'abord en compte la liste entière de mes fichiers à compiler, puis trie et finalement efface tous les doublons.
 
Vote positif 0 Vote négatif

Discussions similaires

PORCHER
  • Question
Microsoft 365 L'indice n'appartient pas à la sélection
Réponses
8
Affichages
320
TooFatBoy
TooFatBoy
A
  • Question
XL 2016 Boucle sur sous répertoire fso.GetFolder SharePoint
Réponses
0
Affichages
279
Aldonanou
A
F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
173
Francky79
F
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
161
rebatte
R
N
  • Question
Microsoft 365 Aide adaptation d'une macro
Réponses
2
Affichages
115
netparty
N
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
83
Latias
L
L
  • Résolu(e)
Microsoft 365 Pb de valeur de variable entre Sub
Réponses
5
Affichages
203
loreak
L
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
190
aziz
A
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
197
Francky79
F
L
  • Résolu(e)
Microsoft 365 Changer code pour sélectionner 3lignes avec un pas de 1
Réponses
4
Affichages
316
laplayast
L

Membres actuellement en ligne

9 membres et 83 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 321
Messages
2 087 260
Membres
103 498
dernier inscrit
FAHDE