Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

[roidurif]

Bonjour,

Je souhaite rassembler plusieurs centaines de fichiers Excel 2007 (de 10 000 lignes) dans un autre seul fichier (Données.xlsx).

Ces 100 fichiers sont des tableaux (90 colonnes et x lignes selon fiches) et sont nommées de cette façon : ex Fiche1.xls, Fiche2.xls, Fiche3.xls,….. Fiche100.xls.

Le but de la macro est de rapatrier dans le document (Données.xls), chaque tableaux, les uns à la suite des autres dans une seule même feuille (Feuil1).

Cette macro copie les onglets par onglet, mais ne fait pas ce que je souhaite, copier les tableaux les uns à la suite des autres.

Merci de votre aide

Sub test()

Chemin = "C:\Documents and Settings\Administrateur\Bureau\Nouveau dossier\"
Fichier = Dir(Chemin & "Copie*")
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
For i = 1 To Sheets.Count
Sheets(i).Copy Workbooks("classeur1.xls").Sheets(1)
Workbooks(Fichier).Activate
Next i
Workbooks(Fichier).Close SaveChanges:=False
Fichier = Dir
Loop

End Sub

 

[kiki29]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Salut, voir https://www.excel-downloads.com/threads/plusieurs-fichiers-dans-1-seul.125099/ et adapter à ton contexte ( Excel 2007 en xlsm ). Le résultat final risque d'être difficile à manipuler

 

[roidurif]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Bonjour

C'est pas facile à adapter.

J'ai trouver ce code sur internet, qui fonctionne sur 2007. Mais le problème est qu' une fois qu'il copie 70 000 lignes, il revient à la 1ere lignes, et donc il écrase les données du début.

Le but est de copier les données les unes apres les autres.

Merci de votre aide.

Public msg As String
 
Sub Appel() 
Dim Chemin As String
    Application.ScreenUpdating = False
        Chemin = "D:\xls\Test\"
        Ouvrir Chemin
    Application.ScreenUpdating = True
    If msg <> "" Then _
    MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiées " & vbCrLf & msg
End Sub

Sub Ouvrir(Chemin As String)
Dim NomFich As String
Dim CL2 As Workbook 'fichier copié
    Application.DisplayAlerts = False 'Evite les messages d'Excel
    'Evite l'exécution éventuelle de macros liées aux fichiers ouverts
    Application.EnableEvents = False
        NomFich = Dir(Chemin & "*.xls")
        If NomFich = "" Then
             MsgBox "Aucun fichier trouvé dans " & Chemin
             Exit Sub
        End If
        Do While NomFich <> ""
            Set CL2 = Workbooks.Open(Chemin & NomFich)
            DoEvents
            Copie CL2
            CL2.Close False
            DoEvents
            ThisWorkbook.Save 'enregistrement du classeur après chaque copie
            DoEvents
            NomFich = Dir
        Loop
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub


Sub Copie(CL2 As Workbook)
Dim LaFeuille As Worksheet, FL1 As Worksheet, derlig As Long
    Set FL1 = ThisWorkbook.Worksheets("feuil1") 'feuille où les données sont collées
    For Each LaFeuille In CL2.Worksheets 'parcours du classeur à copier
        'On vérifie que la feuille n'est pas vide
        If Not (LaFeuille.UsedRange.Address = "$A$1" And Range("A1") = "") Then
            derlig = FL1.Range("A" & Rows.Count).End(xlUp).Row + 1 'première ligne vide
            On Error Resume Next
            LaFeuille.UsedRange.Copy FL1.Cells(derlig, 1)
            DoEvents
            If Err <> 0 Then
                msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
                On Error GoTo 0
            End If
        End If
    Next
End Sub

 

[roidurif]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Re,

J'ai une erreur sur cette ligne

Sheets("Feuil1").Range("A65536").End(xlUp).Row

Pouvez vous me dire svp Pkoi ça bloc ici?

Merci de votre aide.

Sub test()
Application.DisplayAlerts = False
Chemin = "C:\Documents and Settings\Administrateur\Bureau\Nouveau dossier\"
Fichier = Dir(Chemin & "Copie*")
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
For i = 1 To Sheets.Count
Cells.Select
Selection.Copy

Workbooks(Fichier).Activate
Windows("Classeur1.xls").Activate
'Workbooks("Classeur1.xls").Range("A65536").End(xlUp).Row
Sheets("Feuil1").Range("A65536").End(xlUp).Row

ActiveSheet.Paste
Next i
Workbooks(Fichier).Close SaveChanges:=False
Fichier = Dir
Loop
Application.DisplayAlerts = True
End Sub

 

[kiki29]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Salut, effectivement il subsiste qqs problèmes dès que l'on approche l'ancienne limite de 65536 des fichiers "xls" en les manipulant avec Excel 2007, par contre moyennant l'adaptation au format "xlsm" du lien donné plus haut et la conversion des fichiers "xls" en "xlsb" avant la concaténation , cela semblerait fonctionner correctement.
Si cela t'intéresse .....

 

[roidurif]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Salut kiki29;

Ok merci, Tu sais pkoi j'ai une erreur sur mon dernier post

Sheets("Feuil1").Range("A65536").End(xlUp).Row

Merci de ton Aide

 

[kiki29]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Salut, la réponse est oui , tu dois faire qqch comme

Option Explicit

Sub Tst()
Dim i As Long
    i = Sheets("Feuil1").Range("A65536").End(xlUp).Row
    Debug.Print i
End Sub

Sinon en pj les 2 fichiers xlsm , le fichier effectuant la concaténation sera à adapter à ton contexte , je pense sans grosses diffiicultés principalement la constante sNomFeuilleALire ainsi que Wkb.Sheets(sNomFeuilleALire).Range("A1:A" & LastRow).Copy pour la plage à copier dans la procédure Lire(ByVal sNomFichier As String)

Un ou 2 fichiers échantillons seraient les bienvenus ( sans données confidentielles )

 

[roidurif]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Bonjour,

Je ne comprends pas, la macro copie bien les onglets, mais ne fait pas ce que je souhaite, copier les tableaux les uns à la suite des autres, mais plutôt ecrase.



Si vous pouvez m'aider svp

Option Explicit

Sub Tst()
Dim dlgn As Long
    dlgn = Sheets("Feuil1").Range("A65536").End(xlUp).Row
    Debug.Print dlgn
End Sub

Sub test()
Dim Chemin As String
Dim Fichier As String
Dim i As Long

Application.DisplayAlerts = False
Chemin = "C:\Documents and Settings\Administrateur\Bureau\Nouveau dossier\"
Fichier = Dir(Chemin & "*.xls")
Do While Fichier <> ""

For i = 1 To Sheets.Count
Workbooks.Open Filename:=Chemin & Fichier
Worksheets("Référencement").Activate
Cells.Select
Selection.Copy

Workbooks(Fichier).Activate
Windows("Macro Assembler plusieurs fichiers.xlsm").Activate

Tst
ActiveSheet.Paste

Workbooks(Fichier).Close SaveChanges:=False
Fichier = Dir
Next i
Loop
Application.DisplayAlerts = True
End Sub

Merci d'avance

 

[kiki29]

Re : Macro : Rassembler plusieurs fichiers Excel 2007 dans un autre fichier

Salut, visiblement tu n'as strictement rien compris à ce que je voulais dire plus haut avec le debug.print pour i = Sheets("Feuil1").Range("A65536").End(xlUp).Row
.Bref pour te dire que Sheets("Feuil1").Range("A65536").End(xlUp).Row ou mieux i = Sheets("Feuil1").Range("A" & Sheets("Feuil1").Rows.Count).End(xlUp).Row
te renvoie la dernière cellule de la colonne A de la Feuil1 contenant qqch
donc i est à mettre à jour avant collage pour servir au prochain collage, cela veut dire que tu dois l'intégrer dans ton code.
D'autre part concatenation_XLSB.xlsm et Xls2Tab.xlsm devraient t'apporter une solution , as-tu seulement fais l'effort de les essayer ?

PS : d'autant plus que la réponse à ta question y est.