Regrouper plusieurs fichiers Excel sous un seul classeur

Le 06/06/2013 à 16:06

Bonjour tout le monde

Je souhaite regrouper plusieurs fichiers excel sous un seul classeur càd sous format de plusieurs feuilles j'ai exécuté la macro suivante:

Sub regroupe()

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

Set Wf = ThisWorkbook.ActiveSheet ' 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(1)

Wl.Copy After:=Wf

Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur

nbc = nbc + 1

End If

fic = Dir

Wend

fin:

MsgBox nbc & " classeurs regroupés"

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.DisplayAlerts = True

End Sub

Cette macro marche bien sauf qu'elle ne garde pas le nom original de chaque fichier ça génère automatiquement Feuil 1, Feuil 2, Feuil 3, ... Alors que j'ai intérêt que chaque feuille soit identifiée par le nom du fichier .

Pourriez vous m'indiquer comment ajuster ce code pour que les feuilles soient identifiées par leur noms?

Merci bien d'avance

Le 07/06/2013 à 07:10

Bonjour,

A tester et/ou adapter.

Cdlt

Option Explicit
Public Sub regroupe()
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 Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
Dim Nom As String   ' nom feuille copié

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    rep = ThisWorkbook.Path & "\"

    On Error GoTo fin

    Set Wf = ThisWorkbook.ActiveSheet ' 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(1)
            Nom = Split(Dir(Wl.Name), ".")(0)   'nom fichier sans extension
            Wl.Copy After:=Wf
            ActiveSheet.Name = Nom
            Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
            nbc = nbc + 1
        End If
        fic = Dir
    Wend

fin:
    MsgBox nbc & " classeurs regroupés"
    Application.DisplayAlerts = True
End Sub
Le 07/06/2013 à 13:06

Bonjour Jean Eric

Merci bcp pour votre réponse, j'ai essayé votre code ça me génère le msg d'erreur suivant :

Erreur de compilation:

Variable non définie

à savoir je suis une novice en VBA , pourriez vous m'expliquer pas à pas comment adapter ce code à mon besoin, je vous en serais trèèès reconnaissante.

Bonne journée

Le 07/06/2013 à 14:02

Re,

Je n'avais pas réellement analysé ton code.

Voilà qui est fait et cela fonctionne chez moi. Ci-dessous le code modifié, très peu modifié d'ailleurs. J'ai supprimé la variable nbf qui ne servait à rien. Gros travail de ma part

Cdlt

Option Explicit
Public Sub regroupe()
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 Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    rep = ThisWorkbook.Path & "\"

    On Error GoTo fin

    Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
    Wf.Cells.ClearContents
    nbc = 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(1)
            Wl.Copy After:=Wf
            Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
            nbc = nbc + 1
        End If
        fic = Dir
    Wend

fin:
    MsgBox nbc & " classeurs regroupés"
    Application.DisplayAlerts = True
End Sub
Le 07/06/2013 à 15:27

Re

En fait ton code est le même que celui avec quoi je travaillais, ça regroupe effectivement tous les fichiers excel sous un seul classeur mais ça garde pas le nom du fichier sur l'onglet de la feuille.

voici mon besoin, j'ai une centaine de fichiers excel, Ville1_Rendement_, Ville2_Rendement_, Ville3_Rendement_, Ville4_Rendement_..j'ai intérêt à avoir un seul fichier excel qui rassemble tous ces classeurs sous format de feuilles identifiées par leur noms d'origine genre Ville1_Rendement_, Ville2_Rendement_, Ville3_Rendement_, Ville4_Rendement_.. et NON PAS Feuil1, Feuil2, Feuil3..

J'espère avoir bien élucidé mon besoin cette fois-ci.

Grand Merci Eric.

Le 07/06/2013 à 17:09

RE,

On revient à ma première idée...

Testé pour 1 fichier

Cdlt

Option Explicit
Public Sub regroupe()
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 Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
Dim fic_1 As String ' nom fichier sans extension

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    rep = ThisWorkbook.Path & "\"

    On Error GoTo fin

    Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
    Wf.Cells.ClearContents
    nbc = 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
            fic_1 = Split(ActiveWorkbook.Name, ".")(0)
            Set Wl = ActiveWorkbook.Sheets(1)
            Wl.Copy After:=Wf
            ActiveSheet.Name = fic_1
            Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
            nbc = nbc + 1
            Set Wl = Nothing
        End If
        fic = Dir
    Wend

fin:
    MsgBox nbc & " classeurs regroupés"
    Application.DisplayAlerts = True
End Sub
Le 10/06/2013 à 11:39

Bonjour Eric,

Mon problème persiste tjrs les fichiers sont regroupés sous un même classeur mais sans leur nom d'origine

ci-joint le résultat que j’obtiens après l’exécution de la macro.

427cap.docx (235.88 Ko)
Le 10/06/2013 à 12:06

Bonjour,

Cela fonctionne chez moi

Ci-joint fichier pour essai (faire CTRL+a pour lancer la procédure)

Cdlt

1'627excel-pratique.rar (18.47 Ko)
Le 10/06/2013 à 12:56

Enfin ça fonctionne! Grand merci Eric tu m'as sauvé!! j'apprécie énormément tes efforts pour répondre à mon besoin

Dernière qst stp je veux appliquer la mise en forme du 1er fichier à tous les fichiers regroupés est ce possible ?

Le 10/06/2013 à 13:00

Re,

Je ne comprends pas la question. Peux-tu reformuler

Cdlt

Le 10/06/2013 à 13:08

Bon je veux appliquer une mise en forme standard à tous les fichiers que j'ai regroupés d'un seul coup afin d'éviter de mettre en forme fichier par fichier surtout qu'ils ont tous la même structure est ce possible d'enregistrer la macro de la mise en forme du premier fichier et de l'appliquer à tous les fichiers regroupés?

Le 11/06/2013 à 06:06

Bonjour,

Oui bien sûr, mais cela va sérieusement ralentir la procédure de regroupement. Cette mise en forme doit être minimaliste.

Cdlt

Le 11/06/2013 à 10:59

Bonjour,

D'accord c'est bon je vais me contenter du bouton de reproduction de la mise en forme

Merci encore une fois Eric et passe une agréable journéé

Le 21/11/2013 à 09:48

bonjour

je me permet de m'introduire car j'ai le meme besoin , j'ai essayer votre macros marche très bien , mais mon besoin et des classer les fichier un sur un , en trouvant a la fin le dernier fichierv oun un autre fichier contenant touts les fichier excel un sur un

merci de m'aider svp

salutation

Le 12/11/2017 à 17:54

Bonjour, je suis novice en VBA, je souhaiterais avoir un code qui me permettrais de sélectionner à partir d'un une "boite de dialogue"

Plusieurs fichier excel, et en faire un seul général, la subtilité c'est que mon fichier général devra copier uniquement les Page nommé,"feuil1" et que la 'dans la colonne A on mettra le nom du fichier ou provient la ligne.

Merci d'avance pour votre aide

Rechercher des sujets similaires à "regrouper fichiers seul classeur"