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

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

  • Fiche 1.xlsx
    12.6 KB · Affichages: 8
  • Synthèse.xlsx
    9.4 KB · Affichages: 10
Trier par date Trier par votes
chris

chris

XLDnaute Barbatruc
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

  • Synthèse_Fiches_PQ.xlsx
    27 KB · Affichages: 4
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Synthèse.xlsm
    18 KB · Affichages: 2
  • Fiche 1.xlsx
    12.6 KB · Affichages: 0
  • Fiche 2.xlsx
    12.6 KB · Affichages: 0
Dernière édition:
Vote positif 0 Vote négatif
O

Oliiive

XLDnaute Nouveau
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
job75

job75

XLDnaute Barbatruc
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

  • Synthèse(1).xlsm
    18.3 KB · Affichages: 5
  • Fiche 1.xlsx
    12.6 KB · Affichages: 4
  • Fiche 2.xlsx
    12.6 KB · Affichages: 4
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Synthèse(2).xlsm
    20.7 KB · Affichages: 9
  • Fiche 1.xlsx
    12.6 KB · Affichages: 12
  • Fiche 2.xlsx
    12.6 KB · Affichages: 11
Vote positif 0 Vote négatif
O

Oliiive

XLDnaute Nouveau
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

Discussions similaires

hypo78
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
18
Affichages
576
Lolote83
L
N
  • Question
Microsoft 365 Séparer en lignes des données d'une cellule
Réponses
5
Affichages
116
Cousinhub
Cousinhub
B
  • Question
XL 2019 Création d'une base de données à partir de plusieurs fichiers Excel
Réponses
5
Affichages
890
battijo
B
medlight
  • Question
Autres Récupérer des données d'un autre classeur
Réponses
10
Affichages
320
patricktoulon
patricktoulon
C
  • Résolu(e)
XL 2019 Automatiser des formules
Réponses
4
Affichages
187
cotignac
C
N
  • Question
Microsoft 365 recherche v pour récupérer données d'un tableau
Réponses
3
Affichages
155
DJunqueira
D
H
  • Question
Power Query Récupérer une donnée dans des classeurs pour afficher le résultat dans un autre classeur
Réponses
5
Affichages
227
hijackfr
H
F
  • Question
XL pour MAC Création graphique avec plusieurs feuillets
Réponses
7
Affichages
361
alexga78
A
F
  • Question
Microsoft 365 comment ouvrir en lecture/écriture un fichier EXCEL placé sous sharepoint
Réponses
2
Affichages
233
fibled
F
C
  • Question
Microsoft 365 Extraction de datas dans des fichiers pdf
Réponses
2
Affichages
233
kiki29
kiki29

Membres actuellement en ligne

16 membres et 119 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 226
Messages
2 086 413
Membres
103 202
dernier inscrit
Claire2BM