Mise bout à bout de plusieurs Classeur Excel

[MEGAHZ]

Bonjour,
Novice en VBA, je suis à la recherche d'une macro VBA me permettant de mettre bout à bout un nombre aléatoire de classeurs excel de même structure (une seule feuille dans le classeur et 4 colonnes utilisées dans la feuille, par contre le nombre de lignes est aléatoire). Les classeurs à traiter sont tous dans le même répertoire.

Classeur1
A B C D
1 1 1 1
2 2 2 2
3 3 3 3

Classeur2
A B C D
4 4 4 4
5 5 5 5

ClasseurResultat
A B C D
1 1 1 1
2 2 2 2
3 3 3 3
4 4 4 4
5 5 5 5

Merci de votre aide

 

[MEGAHZ]

Re : Mise bout à bout de plusieurs Classeur Excel

Bonjour,
En fouillant sur les Forums j'ai trouvé une macro qui réalise presque ce que je souhaite.Mais je n'arrive pas à la modifier afin d"éviter qu elle reprenne à chaque fois la 1re ligne de chaque classeurs.

Sub Macro1()

Range("A1").Select 'sélectionner la cellule de début
Chemin = "D:\jcpiselli\Mes dossiers\Mes documents\Test Macro\"
Fichier = Dir(Chemin & "*.xls") ' Premier fichier

Do While Fichier <> ""
Set fichierEncours = Workbooks.Open(Filename:=Chemin & Fichier)
fichierEncours.Sheets(1).Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Offset(1, 0)
fichierEncours.Close False
ActiveWorkbook.SaveCopyAs "D:\jcpiselli\Mes dossiers\Mes documents\Test Macro\FichierRésult.xls"
Fichier = Dir ' Fichier suivant
Loop

End Sub

Quelqu'un a une idéee?

 

[Guest]

Re : Mise bout à bout de plusieurs Classeur Excel

bonjour,

A tester:

Sub Macro1()
    Dim Chemin As String, fichier As String, fichierEnCours As Workbook, flag As Boolean
    Range("A1").Select    'sélectionner la cellule de début
    Chemin = "D:\jcpiselli\Mes dossiers\Mes documents\Test Macro\"
    fichier = Dir(Chemin & "*.xls")    ' Premier fichier
    Do While fichier <> ""
        Set fichierEnCours = Workbooks.Open(Filename:=Chemin & fichier)
        With fichierEnCours.Sheets(1).Range("A1").CurrentRegion
            If Not flag Then
                .Copy ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Offset(1, 0)
                flag = True
            Else
                .Offset(1).Resize(.Rows.Count - 1).Copy ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Offset(1, 0)
            End If
        End With
        fichierEnCours.Close False
        ActiveWorkbook.SaveCopyAs "D:\jcpiselli\Mes dossiers\Mes documents\Test Macro\FichierRésult.xls"
        fichier = Dir    ' Fichier suivant
    Loop
End Sub

A+