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