Macro fusion de plusieurs fichiers en un seul

Bonjour à tous,

Voilà question sûrement simple pour beaucoup mais sur laquelle je lutte depuis quelques jours...

J'ai plusieurs fichiers excel avec le même format (j'ai mis un exemple dans la feuil1 du fichier joint) que je mets dans un dossier.

J'ai créé une macro pour récupérer certaines cellules de ces formulaires pour coller dans un tableau (en feuil2 du fichier joint).

Les cellules sont éparpillés dans le formulaire, dans le fichier de synthèse, je veux mettre ces cellules en ligne, chaque valeur correspond à un titre de colonne. Et je passe à la ligne pour le formulaire suivant.

La macro que j'ai créé récupère bien toutes les données mais il me copie toutes les valeurs les une derrière les autres en colonne. Il va à la ligne pour chaque cellule copiée.

Merci pour votre aide et conseils...

Ci-joint le code :

Option Explicit

Sub importDonnees()

Dim principal As ThisWorkbook

Dim repertoire As String, fichier As String

Application.ScreenUpdating = False

Set principal = ThisWorkbook

repertoire = ThisWorkbook.Path

ChDir repertoire

fichier = Dir("*.xlsm")

Do While fichier <> ""

If fichier <> principal.Name Then

Workbooks.Open fichier

On Error GoTo suivant

With Sheets("FEM")

On Error GoTo 0

On Error Resume Next

.Range("B8").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("D8").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("B11").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("B13").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("B15").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("C15").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("G15").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("C19").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("A28").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("A42").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

End With

ActiveWorkbook.Close False

End If

suivant:

If Err.Number = 9 Then MsgBox "Pas de feuille ""FEM"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False

fichier = Dir

Loop

End Sub

47classeur1.xlsx (10.73 Ko)
claude.dasilva a écrit :

.Range("B8").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

.Range("D8").Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)

En effet, à chaque fois tu passes à la ligne suivante puisque la case étant remplie il va chercher la suivante en colonne !!

Il faut

- figer la ligne au début

ligne = principal.Sheets(1).[a65536].End(xlUp).row

- utiliser cette ligne comme destination

.Range("B8").Copy Destination:=principal.Sheets(1).Cells(ligne,1)
.Range("D8").Copy Destination:=principal.Sheets(1).Cells(ligne,2)

Bonjour,

Bonjour Steelson,

Un petit aménagement pour le transfert des données...

Sub importDonnees()
    Dim wsC As Worksheet, Dai(9), adrS, n As Integer, i As Integer
    Dim repertoire As String, fichier As String
    Set wsC = ThisWorkbook.Worksheets(1)
    n = wsC.Cells(Rows.Count, 1).End(xlUp).Row
    adrS = Split("B8 D8 B11 B13 B15 C15 G15 C19 A28 A42")
    repertoire = ThisWorkbook.Path
    ChDir repertoire
    fichier = Dir("*.xlsm")
    Application.ScreenUpdating = False
    Do While fichier <> ""
        If fichier <> ThisWorkbook.Name Then
            Workbooks.Open fichier
            On Error GoTo suivant
            With ActiveWorkbook.Worksheets("FEM")
                On Error GoTo 0
                For i = 0 To 9
                    Dai(i) = .Range(adrS(i))
                Next i
                n = n + 1: wsC.Cells(n, 1).Resize(, 10) = Dai
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then
            MsgBox "Pas de feuille ""FEM"" dans le fichier " & fichier, vbExclamation
            ActiveWorkbook.Close False
        End If
        fichier = Dir
    Loop
End Sub

Cordialement.

Salut MFerrand

adrS = Split("B8 D8 B11 B13 B15 C15 G15 C19 A28 A42")

joli, très pro, bien vu

Bonjour,

Merci à vous deux...

J'avais fini par trouver une solution à mon problème en mettant ce code :

                .Range("B8").Copy Destination:=principal.Sheets(1).Range("A" & principal.Sheets(1).Range("A65536").End(xlUp).Row + 1)
                .Range("D8").Copy Destination:=principal.Sheets(1).Range("B" & principal.Sheets(1).Range("B65536").End(xlUp).Row + 1)
                .Range("B11").Copy Destination:=principal.Sheets(1).Range("C" & principal.Sheets(1).Range("C65536").End(xlUp).Row + 1)
                .Range("B13").Copy Destination:=principal.Sheets(1).Range("D" & principal.Sheets(1).Range("D65536").End(xlUp).Row + 1)
                .Range("B15").Copy Destination:=principal.Sheets(1).Range("E" & principal.Sheets(1).Range("E65536").End(xlUp).Row + 1)
                .Range("C15").Copy Destination:=principal.Sheets(1).Range("F" & principal.Sheets(1).Range("F65536").End(xlUp).Row + 1)
                .Range("G15").Copy Destination:=principal.Sheets(1).Range("G" & principal.Sheets(1).Range("G65536").End(xlUp).Row + 1)
                .Range("C19").Copy Destination:=principal.Sheets(1).Range("H" & principal.Sheets(1).Range("H65536").End(xlUp).Row + 1)
                .Range("A28").Copy Destination:=principal.Sheets(1).Range("I" & principal.Sheets(1).Range("I65536").End(xlUp).Row + 1)
                .Range("A42").Copy Destination:=principal.Sheets(1).Range("J" & principal.Sheets(1).Range("J65536").End(xlUp).Row + 1)
                .Range("K" & .Range("K65536").End(xlUp).Row) = Left(fichier, Len(fichier) - 4)

Mais beaucoup moins efficace que le votre !

Par contre je n'arrive pas à faire fonctionner la ligne :

.Range("K" & .Range("K65536").End(xlUp).Row) = Left(fichier, Len(fichier) - 4)

Le but étant de savoir à quel fichier est associé chaque ligne.

Pouvez-vous m'aider à l'intégrer à votre code svp ?

Merci.

Bonjour,

Petit retour sur mon message précédent.

Quelqu'un peut-il m'aider sur ma dernière question ?

Je voudrais pour chaque ligne que le nom du fichier d'origine soit associé à la ligne.

La ligne n° 45 par exemple, sur la colonne A, qu'il m'affiche le nom du fichier "243.xls".

Merci de votre aide.

Le fichier fonctionne très bien grâce à votre aide, il ne manque que cette dernière option pour faciliter les recherches en cas de doute.

Cordialement.

Bonjour,

Si je comprends bien, c'est une colonne supplémentaire pour ajouter le nom du fichier.

Par rapport à la procédure que j'ai proposée, il faut alors déclarer ; Dai(10) [au lieu de Dai(9)]

Puis dans le corps de la procédure (ajout ou modification surligné) :

                For i = 0 To 9
                    Dai(i) = .Range(adrS(i))
                Next i
                Dai(10) = ActiveWorkbook.Name
                n = n + 1: wsC.Cells(n, 1).Resize(, 11) = Dai

ceci met le nom du fichier en colonne K.

Ou bien :

                For i = 0 To 9
                    Dai(i + 1) = .Range(adrS(i))
                Next i
                Dai(0) = ActiveWorkbook.Name
                n = n + 1: wsC.Cells(n, 1).Resize(, 11) = Dai

ceci met le nom du fichier en colonne A.

Cordialement.

Merci M. Ferrand

J'essaie demain et je vous tiens au courant...

Rechercher des sujets similaires à "macro fusion fichiers seul"