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
Rechercher des sujets similaires à "extraction data fichiers seul"