Microsoft 365 Macro pour récupérer des données dans plusieurs fichiers identiques

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Oliiive
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
O

Oliiive

XLDnaute Nouveau
Bonjour,
Je cherche à récupérer dans un unique fichier de "synthèse" avec une macro les données contenus dans un seul repertoire, qu'on pourra appeler "fiche1,2..."
Merci pour votre aide !!
Olivier
 

Pièces jointes

Trier par date Trier par votes
Bonjour

Plutôt à faire par PowerQuery que par VBA

Modifier le chemin d'accès de la cellule jaune et les paramètres de PowerQuery
Fichier, Options et paramètres, Options de requête, partie GLOBAL : Confidentialité, Toujours ignorer les paramètres de niveau de confidentialité

Puis actualiser
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsoir Oliiive, chris,

Pourquoi pas du VBA ?

Téléchargez les fichiers joints dans le même dossier (le bureau).

Et voyez cette macro dans le ThisWorkbook du fichier Synthèse.xlm :
VB: 
Private Sub Workbook_Activate()
Dim chemin$, fichier$, F As Worksheet, col%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Sheets("Feuil1") 'à adapter
col = 1
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1)
        col = col + 1
        F.Cells(2, col) = Left(.Parent.Name, Len(.Parent.Name) - 5)
        F.Cells(3, col) = .Cells(4, 2)
        F.Cells(4, col) = .Cells(5, 2)
        F.Cells(5, col) = .Cells(6, 2)
        F.Cells(6, col) = .Cells(3, 7)
        F.Cells(7, col) = .Cells(4, 7)
        F.Cells(8, col) = .Cells(9, 7)
        F.Cells(9, col) = .Cells(9, 8)
        F.Cells(12, col) = .Cells(19, 10)
        F.Cells(13, col) = .Cells(20, 10)
        F.Cells(14, col) = .Cells(21, 10)
        F.Cells(15, col) = .Cells(22, 10)
        F.Cells(16, col) = .Cells(23, 10)
        F.Cells(17, col) = .Cells(24, 10)
        .Parent.Close
    End With
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
Elle se déclenche quand on ouvre ou active le fichier.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75 à dit:
Bonsoir Oliiive, chris,

Pourquoi pas du VBA ?

Téléchargez les fichiers joints dans le même dossier (le bureau).

Et voyez cette macro dans le ThisWorkbook du fichier Synthèse.xlm :
VB: 
Private Sub Workbook_Activate()
Dim chemin$, fichier$, F As Worksheet, col%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Sheets("Feuil1") 'à adapter
col = 1
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1)
        col = col + 1
        F.Cells(2, col) = Left(.Parent.Name, Len(.Parent.Name) - 5)
        F.Cells(3, col) = .Cells(4, 2)
        F.Cells(4, col) = .Cells(5, 2)
        F.Cells(5, col) = .Cells(6, 2)
        F.Cells(6, col) = .Cells(3, 7)
        F.Cells(7, col) = .Cells(4, 7)
        F.Cells(8, col) = .Cells(9, 7)
        F.Cells(9, col) = .Cells(9, 8)
        F.Cells(12, col) = .Cells(19, 10)
        F.Cells(13, col) = .Cells(20, 10)
        F.Cells(14, col) = .Cells(21, 10)
        F.Cells(15, col) = .Cells(22, 10)
        F.Cells(16, col) = .Cells(23, 10)
        F.Cells(17, col) = .Cells(24, 10)
        .Parent.Close
    End With
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
Elle se déclenche quand on ouvre ou active le fichier.

A+
Cliquez pour agrandir...
Bonjour JOB 75,
Merci Bcp !!
Après avoir copier vos fichiers dans un repertoire sur mon bureau et ouvert le fichier synthèse, j'ai une erreur "nom ou numéro du fichier incorrect" débogage en jaune sur fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier. Fallait il que je modifie cette ligne ?
Merci
Olivier
 
Vote positif 0 Vote négatif
Voici une version qui fonctionne Sur PC et sur MAC :
VB: 
Private Sub Workbook_Activate()
Dim chemin$, fichier$, F As Worksheet, col%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
Set F = Sheets("Feuil1") 'à adapter
col = 1
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
F.[B:B].Resize(, F.Columns.Count - 1).Delete 'RAZ
While fichier <> ""
    If Right(fichier, 5) = ".xlsx" Then
        With Workbooks.Open(chemin & fichier).Sheets(1)
            col = col + 1
            F.Cells(2, col) = Left(fichier, Len(fichier) - 5)
            F.Cells(3, col) = .Cells(4, 2)
            F.Cells(4, col) = .Cells(5, 2)
            F.Cells(5, col) = .Cells(6, 2)
            F.Cells(6, col) = .Cells(3, 7)
            F.Cells(7, col) = .Cells(4, 7)
            F.Cells(8, col) = .Cells(9, 7)
            F.Cells(9, col) = .Cells(9, 8)
            F.Cells(12, col) = .Cells(19, 10)
            F.Cells(13, col) = .Cells(20, 10)
            F.Cells(14, col) = .Cells(21, 10)
            F.Cells(15, col) = .Cells(22, 10)
            F.Cells(16, col) = .Cells(23, 10)
            F.Cells(17, col) = .Cells(24, 10)
            .Parent.Close
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Et une 2ème version avec ADO qui ne nécessite pas l'ouverture des fichiers sources .xlsx :
Code: 
Private Sub Workbook_Activate()
Dim chemin$, fichier$, feuille$, source, lig, Cn As Object, Cd As Object, Rst As Object, col%, resu(), i%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Feuil1" 'feuille source à copier
source = Array("B4", "B5", "B6", "G3", "G4", "G9", "H9", "J19", "J20", "J21", "J22", "J23", "J24") 'adresses des cellules
lig = Array(3, 4, 5, 6, 7, 8, 9, 12, 13, 14, 15, 16, 17) 'lignes de destination
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
    If Right(fichier, 5) = ".xlsx" Then
        col = col + 1
        Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
        Cd.ActiveConnection = Cn
        ReDim Preserve resu(1 To 17, 1 To col) 'tableau des résultats
        resu(2, col) = Left(fichier, Len(fichier) - 5)
        For i = 0 To UBound(source)
            Cd.CommandText = "SELECT * FROM [" & feuille & "$" & source(i) & ":" & source(i) & "]"
            Rst.Open Cd, , 1, 3
            resu(lig(i), col) = Rst(0)
            Rst.Close
        Next i
        Cn.Close
    End If
    fichier = Dir 'fichier suivant
Wend
'---restitution---
With Sheets("Feuil1")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[B1] '1ère cellule de destination
        If col Then .Resize(UBound(resu), col) = resu
        .EntireColumn.Offset(, col).Resize(, .Parent.Columns.Count - col - .Column + 1).Delete 'RAZ à droite
    End With
    .Columns.AutoFit 'ajustement largeurs
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Et une 2ème version avec ADO qui ne nécessite pas l'ouverture des fichiers sources .xlsx :
Code: 
Private Sub Workbook_Activate()
Dim chemin$, fichier$, feuille$, source, lig, Cn As Object, Cd As Object, Rst As Object, col%, resu(), i%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Feuil1" 'feuille source à copier
source = Array("B4", "B5", "B6", "G3", "G4", "G9", "H9", "J19", "J20", "J21", "J22", "J23", "J24") 'adresses des cellules
lig = Array(3, 4, 5, 6, 7, 8, 9, 12, 13, 14, 15, 16, 17) 'lignes de destination
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
    If Right(fichier, 5) = ".xlsx" Then
        col = col + 1
        Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
        Cd.ActiveConnection = Cn
        ReDim Preserve resu(1 To 17, 1 To col) 'tableau des résultats
        resu(2, col) = Left(fichier, Len(fichier) - 5)
        For i = 0 To UBound(source)
            Cd.CommandText = "SELECT * FROM [" & feuille & "$" & source(i) & ":" & source(i) & "]"
            Rst.Open Cd, , 1, 3
            resu(lig(i), col) = Rst(0)
            Rst.Close
        Next i
        Cn.Close
    End If
    fichier = Dir 'fichier suivant
Wend
'---restitution---
With Sheets("Feuil1")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[B1] '1ère cellule de destination
        If col Then .Resize(UBound(resu), col) = resu
        .EntireColumn.Offset(, col).Resize(, .Parent.Columns.Count - col - .Column + 1).Delete 'RAZ à droite
    End With
    .Columns.AutoFit 'ajustement largeurs
    With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub
Cliquez pour agrandir...
Merci ! Mais ça ne marche pas ... :-//

1675519828283.png
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

S
  • Question Question
Microsoft 365 Consolider des données de plusieurs feuilles
Réponses
2
Affichages
127
Sissou71
S
P
  • Question Question
XL 2019 Macro VBA appliquer un filtre lors d'une importation de données
Réponses
1
Affichages
72
fanch55
fanch55
good57
  • Question Question
Microsoft 365 Récupération de données dans d'autres fichier
Réponses
1
Affichages
63
good57
good57
E
  • Résolu(e)
Microsoft 365 Import POWER QUERY en fonction d'un Mot
Réponses
5
Affichages
51
eric72
E
S
  • Question Question
Microsoft 365 Récuperer des données dans plusieurs répertoires
Réponses
11
Affichages
86
Sissou71
S
P
  • Question Question
XL 2016 VBA Appliquer un filtre sur mes données importées
Réponses
4
Affichages
98
sousou
sousou
S
  • Question Question
Microsoft 365 Tableaux Structurées : récupérer des données uniques pour consolider un bilan
Réponses
4
Affichages
70
vgendron
vgendron
P
  • Question Question
XL 2016 Macro VBA remplissage tableau de synthèse % déchet ligne de production
Réponses
4
Affichages
80
vgendron
vgendron
didier09
  • Résolu(e)
XL 2021 Formule ou VBA pour récupération données sur plusieurs onglets
Réponses
11
Affichages
99
sylvanu
sylvanu
O
  • Question Question
Microsoft 365 Problème complexe de recherche de valeurs
Réponses
6
Affichages
353
Olivier Corbin
O
D
  • Question Question
Microsoft 365 Récupérer une valeur présente dans un autre fichier dont le chemin et le nom est présent dans une cellule
Réponses
6
Affichages
72
wDog66
wDog66
S
  • Question Question
Microsoft 365 Ventiler des données sur une année (sans TCD)
2
Réponses
25
Affichages
356
cathodique
cathodique
pilou010
  • Résolu(e)
XL pour MAC Help INDEX EQUIV ou autre
Réponses
2
Affichages
205
pilou010
pilou010
M
  • Question Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
317
mromain
mromain
T
  • Question Question
Microsoft 365 Besoin d'aide pour transférer des cellules sous plusieurs conditions
Réponses
5
Affichages
521
fanfan38
fanfan38
richardlion
  • Question Question
XL 2016 copie de donnees horizontale en verticale
2
Réponses
25
Affichages
277
job75
job75
vgendron
  • Question Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
1 K
Staple1600
Staple1600
T
  • Question Question
XL 2021 Additionner la couleur du fond et la police de plusieurs cellule en vba
Réponses
7
Affichages
374
Tophe2
T
D
  • Résolu(e)
Microsoft 365 Récupérer la valeur d'une cellule d'un autre fichier
Réponses
7
Affichages
137
Diane272727
D
P
  • Résolu(e)
Microsoft 365 Fusionner classeur avec consolidation des données
Réponses
4
Affichages
240
pierrof
P
Retour