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
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: