Extraction data cellules de plusieurs fichiers vers 1 seul
Bonjour
Je débute en VBA....
voici mon besoin:
j ai un dossier avec plusieurs fichiers dont le contenu est formaté de la même maniere
j ai besoin d'extraire certaines données ( sur la base de coordonnées connues) et de les compiler dans un fichier resultat...
à chaque traitement les donnees extraites doivent etre rangées a la suite , a la premiere ligne vide, dans le fichier source.....
si qqun a un exemple de code, simple, sur la base d'une seule cellule dans les fichiers source...
merci d avance
Bonjour, voici ce que j'utilise dans un de mes fichiers de consolidation.
En espérant que ca t'inspire : tout ce qui est collage de nom d'équipe est facultatif, mais nécessaire dans mon cas car les fichiers de données ne reprennent pas le nom de l'équipe à laquelle ils font référence. Pour ton cas qu'en est-il ?
Sub import_des_infos_dans_onglet_donnees()
'désactiver le message d'Excel
Application.DisplayAlerts = False
'figer l'écran pendant l'exécution de la macro
Application.ScreenUpdating = False
'Définition des dimensions des variables
Dim v_equipe As String
Dim v_nom_equipe As String
Dim v_memoire_equipe As String
Dim v_debut_collage_nom_equipe As String
Dim v_fin_collage_nom_equipe As String
'recherche de la 1ère équipe à importer (onglet dans lequel est inscrit le nom des équipes que je veux consolider, et qui alimente ma variable)
Sheets("Tests pour macro").Select
Range("A2").Select
'lancement de la boucle avec test du contenu de la cellule active (que l'on vient de descendre d'une ligne par rapport l'adresse précédente)
Do While ActiveCell <> ""
'mémoriser la valeur dans la variable v_equipe
v_equipe = ActiveCell.Value
'mémoriser adresse
v_memoire_equipe = ActiveCell.Address
'mémoriser le nom de l'équipe à inscrire dans le fichier
v_nom_equipe = ActiveCell.Offset(0, 1)
'import des données xxx équipe par équipe
'ouvrir le premier fichier xxx et en coller les valeurs
Workbooks.Open Filename:= _
"D:\Mes documents\" & v_equipe
'copier les données de l'onglet saisie
Sheets("Saisie").Select
Range("A2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Range(Selection, ActiveCell.Offset(0, 30)).Select
Selection.Copy
'coller les données dans mon fichier
Windows("mon fichier.xlsm").Activate
Sheets("Données").Select
'sélection de la 1ère cellule vide en seconde colonne et collage
If ActiveCell.Offset(1, 0) <> "" Then
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 1).Select
Else: ActiveCell.Offset(0, 1).Select
End If
ActiveSheet.Paste
'enregistrement des plages pour copie du nom de l'équipe
v_debut_collage_nom_equipe = ActiveCell.Offset(0, -1).Address
ActiveCell.End(xlDown).Select
v_fin_collage_nom_equipe = ActiveCell.Offset(0, -1).Address
'inscrire en colonne A le nom de l'équipe
Range("A1").Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = v_nom_equipe
ActiveCell.Copy
Selection.AutoFill Destination:=Range(v_debut_collage_nom_equipe, v_fin_collage_nom_equipe)
'fermer le fichier d'extraction
Windows(v_equipe & ".xls").Activate
ActiveWindow.Close
'se positionner sur la prochaine équipe grâce à la mémorisation de l'adresse de la dernière cellule vide sélectionnée
Sheets("Tests pour macro").Select
Range(v_memoire_equipe).Offset(1, 0).Select
Loop
Sheets("Données").Select
'confirmer l'exécution de la macro
MsgBox ("Mise à jour terminée")
End Sub
Bonjour et bienvenue
En ce qui me concerne, j'utilise ce code
Sub Importer()
Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = True
DerLg = Range("A65536").End(xlUp).Row + 1
Range("A2:B" & DerLg).Delete
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls*")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In dossier.Files
NomFichier = Fichier.Name
If Not Fichier.Name = "RESULTAT.xlsm" Then
Lg = Range("A65536").End(xlUp).Row + 1
Sheets(1).Range("A" & Lg) = NomFichier
Workbooks.Open Filename:=Chemin & "/" & NomFichier
On Error Resume Next
With Workbooks(NomFichier)
.Sheets(1).Range("C7").Copy ThisWorkbook.Sheets(1).Range("B" & Lg)
.Close
End With
End If
Next
End Sub
- Dans ce code, le fichier contenant la macro se nomme RESULTAT.xslm
- Le fichier RESULTAT.xslm est placé dans le même dossier que les fichiers sources
- Le code récupère les noms des fichiers sources en colonne A et les cellules C7 de chaque 1ère feuille en colonne B
Amicalement
Nad
Bonjour à tous,
On en rajoute une couche :
J'ai considéré que tu avais au minimum une ligne de titre dans le fichier récepteur.
Option Explicit
Sub Récapitulation()
Dim Chemin As String, Fichier_traité As String, Compteur_de_feuilles As Integer, i As Integer, j As Integer
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "\"
Fichier_traité = Dir(Chemin & "*.xls*")
Do While Fichier_traité <> ""
If Fichier_traité = ThisWorkbook.Name Then GoTo Etiquette
Workbooks.Open Chemin & Fichier_traité
For j = 1 To Sheets.Count
If ActiveSheet.Range("A1") <> "" Then
i = ThisWorkbook.Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row
ThisWorkbook.Sheets("Base").Range("A" & i + 1) = ActiveSheet.Range("A1")
End If
Next j
Workbooks(Fichier_traité).Close False
Etiquette:
Fichier_traité = Dir
Loop
End Sub