macro copie cellules formulaire vers un fichier unique

[claude.dasilva]

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

 

[jecherche]

Bonjour,

Il aurait été plus intéressant que les cellules de l'exemple correspondent aux colonnes de ton tableau. C'est un peu bâclé. 😕
Le code n'est pas optimal, mais tu devrais t'y retrouver pour tes modifications ... si besoin est.
Voici, quand même, une proposition...



Jecherche