Fusionner plusieurs feuilles dans un classeur

Bonjour à tous,

Je vous sollicite pour trouver une solution à un problème sur lequel je bloque depuis des jours.

J'aimerais:

1-copier chaque première feuille de 10 classeurs différents se trouvant dans un même dossier, (j'aimerais copier à partir de la ligne A2 des feuilles)

2-fusionner l'ensemble des feuilles copiées dans une unique feuille d'un nouveau classeur

3- l'idéal serait de pouvoir modifier le chemin d'accès du dossier où se trouvent les 10 classeurs sans le modifier directement dans le code via par exemple un userform (si cela est possible, sinon je peux faire autrement )

Comme vous le voyez c'est loin d'être simple et au-dessus de mes compétences en vba

C'est pour cette raison que je fait appel à vous les pros du forum

Merci par avance de votre aide!

John89

bonjour,

une solution

Sub aargh()
    Set wst = ThisWorkbook.Sheets(1)
    dl = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
    If dl > 1 Then dl = dl + 1
    'choix du répertoire
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choisir un répertoire"
        .AllowMultiSelect = False
        If .Show <> 0 Then
            rep = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
        ' masque des fichiers à sélectionner
        m = "*.xlsx"
        f = Dir(rep & m)
        ' on boucle sur les fichiers trouvés
        While f <> ""
            Set wb = Workbooks.Open(rep & f) 'ouverture
            Set wss = wb.Sheets(1) ' 1ere feuille
            dls = wss.Cells(wss.Rows.Count, 1).End(xlUp).Row 'nombre de lignes à copier
            wss.Rows("1:" & dls).Copy wst.Rows(dl) ' copie
            dl = dl + dls ' ajustement pointeur de lignes
            wb.Saved = True
            wb.Close 'fermeture
            f = Dir ' fichier suivant
        Wend
    End With
End Sub

Bonjour h2so4,

Merci de votre aide. Votre travail correspond pratiquement à ce dont j'ai besoin. En effet, lorsque je choisis le répertoire, j'ai l'impression que les feuilles se copient, donc c'est parfait, néanmoins j'ai n'ai pas l'impression qu'elles se collent dans une feuille unique. (Cette feuille unique devrait se trouver dans le classeur ou j'ai copié la macro).

Merci

bonjour,

la copie se fait bien sur une feuille unique. peux-tu mettre deux exemples de fichier à fusionner ?

Bonjour h2so4,

Tu as raison, cela marche parfaitement! MERCI. Une dernière question, chaque feuille à copier comporte un en-tête à l'image du fichier ci-joint. Pourrais-tu modifier la macro pour que cette dernière copie l'ensemble des feuilles à l’exemption des en-êtes?

Merci de ton aide

John89

bonjour,

version adaptée

Sub aargh()
    Set wst = ThisWorkbook.Sheets(1)
    dl = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
    ' e indique s'il faut copier l'entête 1=oui, 2=non
    If dl > 1 Then dl = dl + 1: e = 1 Else e = 2
    'choix du répertoire
   With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choisir un répertoire"
        .AllowMultiSelect = False
        If .Show <> 0 Then
            rep = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
        ' masque des fichiers à sélectionner
       m = "*.xlsx"
        f = Dir(rep & m)
        ' on boucle sur les fichiers trouvés
       While f <> ""
            Set wb = Workbooks.Open(rep & f) 'ouverture
           Set wss = wb.Sheets(1) ' 1ere feuille
           dls = wss.Cells(wss.Rows.Count, 1).End(xlUp).Row 'nombre de lignes à copier
           wss.Rows(e & ":" & dls).Copy wst.Rows(dl) ' copie
           dl = dl + dls + 1 - e ' ajustement pointeur de lignes
           e = 2 'on ne copie pas l'entête du fichier suivant
           wb.Saved = True
            wb.Close 'fermeture
           f = Dir ' fichier suivant
       Wend
    End With
End Sub

Bonjour h2so4,

ça marche parfaitement, merci

Bonjour h2so4,

La macro fonctionne parfaitement mais est-il possible de la modifier une dernière fois cette dernière pour commencer à copier les feuilles à partir de la ligne 3. En effet, l'entête des colonnes se trouvent à la ligne 3 et non en ligne 2 comme je l'avais énoncé.

Merci une nouvelle fois de ton aide

John89

bonjour,

Sub aargh()
    Set wst = ThisWorkbook.Sheets(1)
    dl = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
    ' e indique s'il faut copier l'entête 2=oui, 3=non
   If dl > 1 Then dl = dl + 1: e = 2 Else e = 3
    'choix du répertoire
  With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choisir un répertoire"
        .AllowMultiSelect = False
        If .Show <> 0 Then
            rep = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
        ' masque des fichiers à sélectionner
      m = "*.xlsx"
        f = Dir(rep & m)
        ' on boucle sur les fichiers trouvés
      While f <> ""
            Set wb = Workbooks.Open(rep & f) 'ouverture
          Set wss = wb.Sheets(1) ' 1ere feuille
          dls = wss.Cells(wss.Rows.Count, 1).End(xlUp).Row 'nombre de lignes à copier
          wss.Rows(e & ":" & dls).Copy wst.Rows(dl) ' copie
          dl = dl + dls + 1 - e ' ajustement pointeur de lignes
          e = 3 'on ne copie pas l'entête du fichier suivant
          wb.Saved = True
            wb.Close 'fermeture
          f = Dir ' fichier suivant
      Wend
    End With
End Sub

c,'est parfait merci