VBA Excel - Récupération des noms et des données de différents fichiers

Le 05/11/2020 à 16:02

Bonjour, voici ce que j'aimerais faire : J'ai plusieurs fichiers qui se nomme ainsi : Date_Nom_Prénom.
Dans ces fichiers j'ai dans la cellule D25 : un total.
J'aimerais regrouper tout ces fichiers dans un tableau avec en colonne A : la date, en colonne B : le nom, en colonne C : le prénom, et en colonne D : le total.
Dans ce tableau, il y aurait pour chaque ligne, un fichier.
Merci d'avance

1305-11-2020-nom-prenom.xlsx (9.53 Ko)
14classeurtest.xlsm (16.51 Ko)
Le 05/11/2020 à 17:08

Bonjour Ouiouinonnon, bonjour le forum

En pièce jointe ton fichier modifié. Si tous les fichiers se trouvent dans le même dossier que ce fichier, alors le code-ci-dessous fonctionnera :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim D As Date 'déclare la variable D (Date)
Dim N As String 'déclare la variable N (Nom)
Dim P As String 'déclare la variable P (Prénom)
Dim T As Integer 'déclare la variable T (Total)
Dim LI As Integer 'déclare la variable LI (LIgne)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Test") 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier excel (.xlsx) du dossier CA
Do While F <> "" 'exécute tant qu'il existe des fichiers F
    Set CS = Workbooks.Open(CA & F) 'définit le classeur source CS (en l'ouvrant)
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS
    D = DateSerial(Split(F, "-")(2), Split(F, "-")(1), Split(F, "-")(0)) 'définit la date D
    N = Split(F, "-")(3) 'définit le nom N
    P = Split(F, "-")(4) 'définit le prénom P
    T = OS.Range("D25").Value 'récupère le total T
    OD.ListObjects(1).ListRows.Add 'ajoute une ligne au tableau "Tableau2"
    LI = IIf(OD.Range("A2").Value = "", 2, OD.Range("A1").End(xlDown).Row + 1) 'définit la ligne LI
    OD.Cells(LI, 1).Value = D 'renvoie la date dans la cellule ligne LI colonne 1 de l'onglet OD
    OD.Cells(LI, 2).Value = N 'renvoie le nom dans la cellule ligne LI colonne 2 de l'onglet OD
    OD.Cells(LI, 3).Value = P 'renvoie le prénom dans la cellule ligne LI colonne 3 de l'onglet OD
    OD.Cells(LI, 4).Value = T 'renvoie le total dans la cellule ligne LI colonne 4 de l'onglet OD
    CS.Close False 'ferme le classeur source
    F = Dir 'définit le prochain fichier excel (.xlsx) du dossier CA
Loop 'boucle
End Sub

Le fichier modifié :

10classeurtest-1.xlsm (22.22 Ko)


Le 05/11/2020 à 17:14

Bonjour,

Je me suis également intéressé à ce problème. Voici ma solution. Comme pour ThauThème, tous les fichiers à visiter - et aucun autre - doivent être dans le même dossier que ce fichier de base. Sinon il faudrait modifier le code.

Option Explicit
Sub En_revue()
    Dim Fichier_traité As String, Chemin As String, DerLig As Integer, Signe_1 As Byte, Signe_2 As Byte, Signe_3 As Byte

    Application.ScreenUpdating = False

    Range("A2:D" & Rows.Count).ClearContents

    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.*")

    Do While Fichier_traité <> ""
        If Fichier_traité = ThisWorkbook.Name Then GoTo Etiquette
        Signe_1 = WorksheetFunction.Search("_", Fichier_traité)
            Signe_2 = WorksheetFunction.Search("_", Fichier_traité, Signe_1 + 1)
            Signe_3 = WorksheetFunction.Search(".", Fichier_traité, Signe_2 + 1)
        With ThisWorkbook.Sheets("Test")
            Workbooks.Open Chemin & Fichier_traité
            DerLig = .Range("A" & Rows.Count).End(xlUp).Row
                .Range("A" & DerLig + 1) = Left(Fichier_traité, 10)
                .Range("B" & DerLig + 1) = Mid(Fichier_traité, Signe_1 + 1, Signe_2 - Signe_1 - 1)
                .Range("C" & DerLig + 1) = Mid(Fichier_traité, Signe_2 + 1, Signe_3 - Signe_2 - 1)
                .Range("D" & DerLig + 1) = ActiveSheet.Range("D25")
            End With
        Workbooks(Fichier_traité).Close False
Etiquette:

    Fichier_traité = Dir
    Loop

End Sub

Cordialement.

4classeur-test-v1.xlsm (21.36 Ko)
Le 05/11/2020 à 17:26

Merci pour vos réponses, je suis en train de regarder tout ça

Le 05/11/2020 à 17:35

Attention : j'ai considéré que les noms et prénoms de tes fichiers était comme tu l'indiques dans ton premier message, séparés par des soulignés.

Soit 05-11-2020_Nom_Prénon et non pas 05-11-2020-Nom-Prénom

Le 05/11/2020 à 17:57

En effet merci, le problème c'est que je me suis trompé dans le nom des fichiers, ce n'est pas 05-11-2020_Nom_Prénom mais Nom_Prénom_05-11-2020.

Ce n'est pas grand chose mais j'essaye sans succès de modifier vos lignes de codes

Le 05/11/2020 à 18:16

Voici une version modifiée.

9classeur-test-v2.xlsm (22.70 Ko)
Sub En_revue()
    Dim Fichier_traité As String, Chemin As String, DerLig As Integer, Signe_1 As Byte, Signe_2 As Byte, Signe_3 As Byte

    Application.ScreenUpdating = False

    Range("Tableau2").Clear
    ActiveSheet.ListObjects("Tableau2").Resize Range("A1:D2")

    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.*")

    Do While Fichier_traité <> ""
        If Fichier_traité = ThisWorkbook.Name Then GoTo Etiquette
        Signe_1 = WorksheetFunction.Search("_", Fichier_traité)
        Signe_2 = WorksheetFunction.Search("_", Fichier_traité, Signe_1 + 1)
        Signe_3 = WorksheetFunction.Search(".", Fichier_traité, Signe_2 + 1)
        With ThisWorkbook.Sheets("Test")
            Workbooks.Open Chemin & Fichier_traité
            If .Range("A2") = "" Then
                DerLig = 2
            Else
                DerLig = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
                .Range("A" & DerLig) = Mid(Fichier_traité, Signe_2 + 1, 10)
                .Range("B" & DerLig) = Left(Fichier_traité, Signe_1 - 1)
                .Range("C" & DerLig) = Mid(Fichier_traité, Signe_1 + 1, Signe_2 - Signe_1 - 1)
                .Range("D" & DerLig) = ActiveSheet.Range("D25")
            End With
        Workbooks(Fichier_traité).Close False
Etiquette:

    Fichier_traité = Dir
    Loop

End Sub
Le 05/11/2020 à 18:20

Re,

Idem :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim F As String 'déclare la variable F (Fichier)
Dim D As Date 'déclare la variable D (Date)
Dim N As String 'déclare la variable N (Nom)
Dim P As String 'déclare la variable P (Prénom)
Dim T As Integer 'déclare la variable T (Total)
Dim LI As Integer 'déclare la variable LI (LIgne)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Test") 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier excel (.xlsx) du dossier CA
Do While F <> "" 'exécute tant qu'il existe des fichiers F
    Set CS = Workbooks.Open(CA & F) 'définit le classeur source CS (en l'ouvrant)
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS
    D = DateSerial(Split(F, "_")(2), Split(F, "_")(1), Split(F, "_")(0)) 'définit la date D
    N = Split(F, "_")(3) 'définit le nom N
    P = Split(F, "_")(4) 'définit le prénom P
    T = OS.Range("D25").Value 'récupère le total T
    OD.ListObjects(1).ListRows.Add 'ajoute une ligne au tableau "Tableau2"
    LI = IIf(OD.Range("A2").Value = "", 2, OD.Range("A1").End(xlDown).Row + 1) 'définit la ligne LI
    OD.Cells(LI, 1).Value = D 'renvoie la date dans la cellule ligne LI colonne 1 de l'onglet OD
    OD.Cells(LI, 2).Value = N 'renvoie le nom dans la cellule ligne LI colonne 2 de l'onglet OD
    OD.Cells(LI, 3).Value = P 'renvoie le prénom dans la cellule ligne LI colonne 3 de l'onglet OD
    OD.Cells(LI, 4).Value = T 'renvoie le total dans la cellule ligne LI colonne 4 de l'onglet OD
    CS.Close False 'ferme le classeur source
    F = Dir 'définit le prochain fichier excel (.xlsx) du dossier CA
Loop 'boucle
End Sub
Le 05/11/2020 à 18:22

Merci à vous deux

Rechercher des sujets similaires à "vba recuperation noms donnees differents fichiers"