Fusionner des fichiers d'un dossier

Suzi

XLDnaute Nouveau
Bonjour,

J'aimerais créer un fichier excel à partir d'autres fichiers excel.
Chaque onglet doit avoir le nom du fichier qui a été copié et reprendre les données du premier onglet.

EX : J'ai 3 fichiers dans un dossier
ABC.xls
DEF.xls
HIJ.xls

J'aimerais avoir un fichier ou

l'onglet 1 sera nommé ABC et contiendra le contenu de l'onglet 1 du fichier ABC
l'onglet 2 sera nommé DEF et contiendra le contenu de l'onglet 1 du fichier DEF
l'onglet 3 sera nommé HIJ et contiendra le contenu de l'onglet 1 du fichier HIJ

J'aimerais creer autant d'onglet que de fichier présent dans le dossier.
je vais devoir le faire de manière récurrente sur plein de dossier :-(
Et y'en a un ou il y a 550 fichiers. :-(

Quelqu'un pourrait il m'aider ?

Suz


Merci
 

Guiv

XLDnaute Occasionnel
Re : Fusionner des fichiers d'un dossier

Bonjour,

Si j'ai bien compris, vois la proposition ci-jointe.

1) les trois classeurs ABC.xls, DEF.xls et HIJ.xls réunis dans un même dossier.
2) Un classeur "Récap.xls" créé dans le même répertoire
3) La première partie de la macro (chinée sur ce forum en faisant une petite recherche) liste les classeurs du dossier à l'exception du classeur "Récap"
4) la deuxième partie copie la première feuille de chaque classeur dans le classeur "Récap"

Bonne journée,
Guiv
 

Pièces jointes

  • MonDossier.zip
    24.5 KB · Affichages: 129
  • MonDossier.zip
    24.5 KB · Affichages: 127
  • MonDossier.zip
    24.5 KB · Affichages: 126

Suzi

XLDnaute Nouveau
Re : Fusionner des fichiers d'un dossier

Bonjour,

Si j'ai bien compris, vois la proposition ci-jointe.

1) les trois classeurs ABC.xls, DEF.xls et HIJ.xls réunis dans un même dossier.
2) Un classeur "Récap.xls" créé dans le même répertoire
3) La première partie de la macro (chinée sur ce forum en faisant une petite recherche) liste les classeurs du dossier à l'exception du classeur "Récap"
4) la deuxième partie copie la première feuille de chaque classeur dans le classeur "Récap"

Bonne journée,
Guiv


T'es un as !!!! Merci !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!:D
 

PMO2

XLDnaute Accro
Re : Fusionner des fichiers d'un dossier

Bonjour,

J'ai programmé cette solution qui j'espère , si vous êtes novice en VBA, ne va pas vous effrayer par sa complexité.

CELA FAIT
1) affichage d'une boîte de dialogue pour sélectionner le dossier contenant les classeurs à agréger
2) recherche de tous les classeurs dans ce dossier et vérification si il y en a d'ouvert
3) copie de chaque 1er onglet dans un nouveau classeur et sauvegarde de ce dernier dans le dossier sélectionné

Votre demande a soulevé plusieurs interrogations qui ont éveillé ma curiosité et dont les solutions pourront intéresser certains.

1) utilisation de "BrowseForFolder" : comment pouvoir sélectionner les dossiers spéciaux Bureau, Mes documents ?
(usage des API SHGetPathFromIDList et SHGetSpecialFolderLocation)

2) utilisation de GetObject pour charger les classeurs : comment empêcher l'action des macros auto_open si il y en a ?
(usage de Application.EnableEvents = False )

3) si des contrôles ActiveX existent dans un classeur, comment désactiver le message d'alerte de Microsoft Forms
"Cette application est sur le point d'initialiser les contrôles ActiveX potentiellement non sûrs. Si la source de ce fichier
est fiable, cliquez sur OK pour que les contrôles soient initialisés à l'aide des paramètes d'espace de travail en cours." ?
(emploi des API SendMessage, FindWindow, SetTimer, KillTimer, GetWindowText)

Voici les codes à copier dans 2 modules standards différents

Module 1
Code:
Sub pmo_AgregerPremiersOnglets()
Dim objShell As Object  'Shell32.Shell
Dim objFolder As Object 'Shell32.Folder
Dim Chemin$
Dim DossierRacine&
Dim Retour&
Dim A$
Dim IDL As ITEMIDLIST
Dim i&
Dim Classeurs$()
Dim WB As Workbook
Dim NewWB As Workbook
'--- Choix d'un dossier ---
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
Chemin$ = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
      '°°° Dossiers spéciaux °°°
If objFolder.Title = "Bureau" Then
  Chemin$ = PathSpecial(CSIDL_DESKTOP)
ElseIf objFolder.Title = "Mes documents" Then
  Chemin$ = PathSpecial(CSIDL_PERSONAL)
End If
      '°°°°°°°°°°°°°°°°°°°°°°°°°
If objFolder.Title = "" Then Chemin$ = ""
DossierRacine& = InStr(objFolder.Title, ":")
If DossierRacine& > 0 Then Chemin$ = Mid(objFolder.Title, DossierRacine& - 1, 2) & ""
If Chemin$ = "" Then Exit Sub
On Error GoTo 0
'--- Recherche tous les classeurs contenus dans le dossier sélectionné ---
With Application.FileSearch
  .LookIn = Chemin$
  .FileType = msoFileTypeExcelWorkbooks
  .Execute
  If .FoundFiles.Count = 0 Then
    MsgBox "Aucun classeur .xls n'a été trouvé dans " & Chemin$ & ""
    Exit Sub
  End If
  ReDim Classeurs$(1 To .FoundFiles.Count, 1 To 2)
  For i& = 1 To .FoundFiles.Count
    Classeurs$(i&, 1) = .FoundFiles(i&)
    Classeurs$(i&, 2) = Mid(Classeurs(i&, 1), InStrRev(Classeurs$(i&, 1), "\") + 1)
  Next i&
End With
'--- Vérification si des classeurs sont déjà ouverts ---
For i& = 1 To UBound(Classeurs$, 1)
  On Error Resume Next
  Set WB = Workbooks(Classeurs(i&, 2))
  If Not WB Is Nothing Then
    MsgBox "Le classeur ''" & Classeurs(i&, 2) & "'' est ouvert. Veuillez le fermer."
    Exit Sub
  End If
Next i&
On Error GoTo 0
'--- Création d'un nouveau classeur pour agrégation ---
On Error GoTo Erreur
Application.ScreenUpdating = False
Set NewWB = Workbooks.Add(xlWBATWorksheet)
NewWB.Sheets(1).Name = "____tempo"  'pour éviter un conflit de noms
'--- Copie des feuilles (1) ---
Application.EnableEvents = False    'pour désactiver les macros auto_open
OnTimer& = 0
Call RunTimer(Delai:=0) 'Pour éviter le message d'alerte Microsoft Forms des ActiveX non sûrs
For i& = 1 To UBound(Classeurs$, 1)
  Application.DisplayAlerts = False
  Set WB = GetObject(Classeurs$(i&, 1))
  Application.StatusBar = WB.Name
  WB.Sheets(1).Copy After:=NewWB.Sheets(NewWB.Sheets.Count)
  NewWB.Sheets(NewWB.Sheets.Count).Name = Mid(Classeurs$(i&, 2), 1, Len(Classeurs$(i&, 2)) - 4)
  WB.Close
  Set WB = Nothing
Next i&
Call OffTimer 'désactive la routine "Pour éviter le message d'alerte Microsoft Forms des ActiveX non sûrs"
'--- Sauvegarde du nouveau classeur ---
NewWB.Sheets(1).Delete
A$ = Chemin$ & "\Récapitulatif " & Replace(Replace(CStr(Now), "/", "-"), ":", ".") & ".xls"
NewWB.SaveAs A$
MsgBox Title:="Traitement terminé", Buttons:=vbInformation, _
    prompt:="Le résultat de l'agrégation est dans le classeur :" & vbCrLf & A$
'--- Pseudo traitement d'erreur ---
Erreur:
On Error Resume Next
WB.Close
Set WB = Nothing
NewWB.Close
Set NewWB = Nothing
Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Module 2
Code:
'______________________________________________________________________

'###################################################################
'### Connaître le chemin du Bureau et le chemin de Mes documents ###
'###################################################################
  '/// API ///
Declare Function SHGetPathFromIDList& Lib "shell32.dll" ( _
  ByRef pidl As Long, ByVal pszPath As String)
Declare Function SHGetSpecialFolderLocation& Lib "shell32.dll" ( _
  ByVal hwnd As Long, ByVal csidl As Long, ByRef ppidl As ITEMIDLIST)
  '/// Constantes ///
Public Const CSIDL_DESKTOP = &H0
Public Const CSIDL_PERSONAL = &H5
  '/// Types ///
Type SHITEMID
  cb As Long
  abID As Byte
End Type
Type ITEMIDLIST
  mkid As SHITEMID
End Type
'###################################################################

'______________________________________________________________________

'##############################################################################################
'###          Pour éviter le message d'alerte Microsoft Forms des ActiveX non sûrs          ###
'##############################################################################################
'### Cette application est sur le point d'initialiser des contrôles ActiveX potentiellement ###
'### dangereux. Si la source du document est de confiance, sélectionnez Oui                 ###
'### et le contrôle sera initialisé en utilisant vos paramètres de document.                ###
'##############################################################################################
  '/// API ///
Private Declare Function SendMessage& Lib "user32" _
  Alias "SendMessageA" (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
Private Declare Function FindWindow& Lib "user32" _
  Alias "FindWindowA" (ByVal lpClassName As String, _
  ByVal lpWindowName As String)
Private Declare Function SetTimer& Lib "user32" _
  (ByVal hwnd As Long, ByVal nIDEvent As Long, _
  ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Private Declare Function KillTimer& Lib "user32" _
  (ByVal hwnd As Long, ByVal nIDEvent As Long)
Private Declare Function GetWindowText& Lib "user32" _
  Alias "GetWindowTextA" _
  (ByVal hwnd As Long, ByVal lpString As String, _
   ByVal cch As Long)
  '/// Constante ///
Private Const TITRE_MSGBOX As String = "Microsoft Forms"
  '/// Globale ///
Public OnTimer&
'___________________________
Private Sub CloseMsgBox()
Dim HwndMsgBox&
HwndMsgBox& = FindWindow(vbNullString, TITRE_MSGBOX)
Dim Ch$
Dim Tampon&
Dim reponse&
Ch$ = Space(1024)
Tampon& = Len(Ch$)
reponse& = GetWindowText(HwndMsgBox&, Ch$, Tampon&)
Ch$ = Trim(Replace(Ch$, Chr$(0), ""))
If Ch$ = TITRE_MSGBOX Then
  SendMessage HwndMsgBox&, &H10, 0, ByVal 0&
End If
End Sub
'___________________________
Sub RunTimer(Delai&)
If OnTimer& > 0 Then OffTimer
OnTimer& = SetTimer(0, 0, ByVal Delai&, AddressOf CloseMsgBox)
End Sub
'___________________________
Sub OffTimer(Optional dummy As Byte)
If OnTimer& > 0 Then
  OnTimer& = KillTimer(0&, OnTimer&)
  OnTimer& = 0
End If
End Sub
'##############################################################################################


'###################################################################
'### Connaître le chemin du Bureau et le chemin de Mes documents ###
'###################################################################
'____________________________________
Function PathSpecial(SpecialFolder As Long) As String
Dim Retour&
Dim A$
Dim IDL As ITEMIDLIST
  Retour& = SHGetSpecialFolderLocation(0, SpecialFolder, IDL)
  If Retour& = 0 Then
    A$ = Space(512)
    Retour& = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal A$)
    PathSpecial = Left(A$, InStr(A$, vbNullChar) - 1)
  End If
End Function

Il n'y a plus qu'à lancer la macro "pmo_AgregerPremiersOnglets".

Cordialement.

PMO
Patrick Morange
 

Suzi

XLDnaute Nouveau
Re : Fusionner des fichiers d'un dossier

Bonjour à tous !!

Again me ... :)

J'aimerais savoir si il est possible de modifier cette macro ou le fichier pour ne plus avoir un onglet par fichier mais que tout soit copié dans le meme onglet à la suite ?

Merci !!!
 

Suzi

XLDnaute Nouveau
Re : Fusionner des fichiers d'un dossier

Bonjour,

A qui s'adresse votre message, à Guiv ou à moi ?
Pour plus de précisions, quelle macro (que vous utilisez) faut-il modifier ?

Cordialement.

PMO
Patrick Morange

A l'un de vous deux car les deux fichier fonctionnés.
Comme j'ai demandé gentillement :)
Il faudrait un fichiet qui copie tout a la suite dans un meme onglet / meme sheet

Merci PMO !!
 

spoussier

XLDnaute Nouveau
Re : Fusionner des fichiers d'un dossier

Bonjour,

Si j'ai bien compris, vois la proposition ci-jointe.

1) les trois classeurs ABC.xls, DEF.xls et HIJ.xls réunis dans un même dossier.
2) Un classeur "Récap.xls" créé dans le même répertoire
3) La première partie de la macro (chinée sur ce forum en faisant une petite recherche) liste les classeurs du dossier à l'exception du classeur "Récap"
4) la deuxième partie copie la première feuille de chaque classeur dans le classeur "Récap"

Bonne journée,
Guiv

Bonjour,

Je suis novice et ai utilisé votre solution que je trouve très pratique.
Le seul problème: j'aimerai déplacer et renommer le bouton commande mais je n'y arrive pas.:(
Est ce à cause de la fonction Private ?
Je ne peux accéder aux autres librairies car il faut un mot de passe.
Pouvez vous m'aider ? :confused:

Merci
Samuel
 

Guiv

XLDnaute Occasionnel
Re : Fusionner des fichiers d'un dossier

Bonjour spoussier et bienvenue sur le forum,

D'abord, il faut afficher la barre d'outils "Boîte à outils contrôles" (Affichage/Barre d'outils/).

Se mettre en mode "création" avec la 1ere icône de la barre d'outils.
Pour déplacer le bouton dans la feuille, cliquer dessus et le faire glisser.
Pour le modifier (texte, couleur...) clic droit / Propriétés.

Puis quitter le mode création pour que la macro fonctionne. Et voilà!

En espérant avoir répondu à ta demande,
Cordialement,
Guiv

Au fait, si tu as d'autres demandes sur ce thème (maniement des boutons etc.), il vaudrait mieux créer un autre fil...
G.
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
312 294
Messages
2 086 895
Membres
103 404
dernier inscrit
sultan87