XL 2016 alimenter un tableau en recopiant des cellules de fichiers fermés

L

Le novice

XLDnaute Junior
bonjour à tous et meilleurs voeux.
J'aimerais dans un fichier excel pouvoir recenser tous les autres fichiers (dans un état fermé) d'un repertoire en recopiant le nom de chaque fichier dans la colonne A
Par la suite sur la colonne B en face de chaque nom de fichier j'aimerais que soit recopiée la cellule G5 de chaque fichier du répertoire.
tout ceci doit donc se faire à partir d'un bouton de commande qui mettra à jour ce tableau.
j'espere avoir été assez explicite dans mes explications
merci de vootre aide par avance.
 
Solution
job75
En supposant que la 2ème date se situe en I5 voyez ce fichier (2) et la macro :
VB: 
Sub MAJ()
Dim F As Worksheet, chemin$, fichier$, feuille$, a(), n&, x$
Set F = Feuil1 'CodeName, à adapter
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
feuille = "MaFeuille" 'à adapter
ReDim a(1 To F.Rows.Count, 1 To 3)
'---analyse du dossier---
While fichier <> ""
    n = n + 1
    a(n, 1) = fichier
    x = "'" & chemin & "[" & fichier & "]" & feuille
    a(n, 2) = ExecuteExcel4Macro(x & "'!R5C7"): If a(n, 2) = 0 Then a(n, 2) = ""
    a(n, 3) = ExecuteExcel4Macro(x & "'!R5C9"): If a(n, 3) = 0 Then a(n, 3) = ""
    fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
If...
Trier par date Trier par votes
xUpsilon

xUpsilon

XLDnaute Accro
Bonjour,

Pour lire dans un classeur fermé :
VB: 
Sub extractionValeurCelluleClasseurFerme()
    Dim Source As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim ADOCommand As ADODB.Command
    Dim Fichier As String, Cellule As String, Feuille As String
   
    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "B4:B4"
      'Pour une plage de cellules, utilisez:
      'Cellule = "A4:C10"
     
    Feuille = "Feuil1$" 'n'oubliez pas d'ajouter $ au nom de la feuille.
    'Chemin complet du classeur fermé
    Fichier = "C:\Base.xls"
               
    Set Source = New ADODB.Connection
    Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
               
    Set ADOCommand = New ADODB.Command
    With ADOCommand
        .ActiveConnection = Source
        .CommandText = "SELECT * FROM [" & Feuille & Cellule & "]"
    End With
                 
    Set Rst = New ADODB.Recordset
    Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
                 
    Set Rst = Source.Execute("[" & Feuille & Cellule & "]")
   
    Range("A2").CopyFromRecordset Rst
           
    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
End Sub

NB : Il s'agit ici d'un exemple retrouvé, copié et collé. Celui-ci ne se contente pas seulement de lire une donnée, mais également de la manipuler. Je te laisse t'intéresser au sujet pour comprendre comment cela fonctionne/quelle partie garder.

Pour boucler sur tous les fichiers d'un répertoire :
Code: 
Sub BoucleFichiers()
    Dim Chemin As String, Fichier As String, i As Integer, Semaine As String, Somme As Double
   
    i = 1
    Semaine = InputBox("Quel est le mois de l'année ? (format aaaa Sem ss)")
    'Définit le répertoire contenant les fichiers
    Chemin = "D:\documents\a\"

    'Boucle sur tous les fichiers xls du répertoire.
    Fichier = Dir(Chemin & "*.xlsm")
    'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers :
    'Fichier = Dir(Chemin & "*.*")

    Do While Len(Fichier) > 0
        'Insérer les lignes de code ici
           Fichier = Dir()
    Loop
End Sub

Bonne continuation
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour didi1, James007, xUpsilon,

La méthode ADO à utiliser dépend de la version Excel, cette macro est plus simple :
VB: 
Sub MAJ()
Dim F As Worksheet, chemin$, fichier$, feuille$, a(), n&
Set F = Feuil1 'CodeName, à adapter
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
feuille = "MaFeuille" 'à adapter
ReDim a(1 To F.Rows.Count, 1 To 2)
'---analyse du dossier---
While fichier <> ""
    n = n + 1
    a(n, 1) = fichier
    a(n, 2) = ExecuteExcel4Macro("'" & chemin & "[" & fichier & "]" & feuille & "'!R5C7")
    fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
With F.[A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 2) = a
    .Offset(n).Resize(F.Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
    .EntireColumn.Resize(, 2).AutoFit 'ajustement largeurs
End With
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Téléchargez les fichiers joints dans le même dossier (le bureau).

Edit : pour tester j'ai créé 1000 fichiers sources .xlsx, chez moi la macro s'exécute en 2,4 secondes.

A+
 

Pièces jointes

  • Récap(1).xlsm
    18.2 KB · Affichages: 22
  • Source1.xlsx
    9.3 KB · Affichages: 13
  • Source2.xlsx
    8.5 KB · Affichages: 13
Dernière édition:
Vote positif 0 Vote négatif
L

Le novice

XLDnaute Junior
job75 à dit:
Bonjour didi1, James007, xUpsilon,

La méthode ADO à utiliser dépend de la version Excel, cette macro est plus simple :
VB: 
Sub MAJ()
Dim F As Worksheet, chemin$, fichier$, feuille$, a(), n&
Set F = Feuil1 'CodeName, à adapter
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
feuille = "MaFeuille" 'à adapter
ReDim a(1 To F.Rows.Count, 1 To 2)
'---analyse du dossier---
While fichier <> ""
    n = n + 1
    a(n, 1) = fichier
    a(n, 2) = ExecuteExcel4Macro("'" & chemin & "[" & fichier & "]" & feuille & "'!R5C7")
    fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
With F.[A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 2) = a
    .Offset(n).Resize(F.Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
    .EntireColumn.Resize(, 2).AutoFit 'ajustement largeurs
End With
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Téléchargez les fichiers joints dans le même dossier (le bureau).

Edit : pour tester j'ai créé 1000 fichiers sources .xlsx, chez moi la macro s'exécute en 2,4 secondes.

A+
Cliquez pour agrandir...
J'ai donc testé votre code il fonctionne correctement , néamoins la cellule à recopier est une date j'ai donc modifier le format de cellule dans la colonne B du fichier récap. mon probleme es que lorsque la cellule G5 du fichier source est vide la date 01/01/1900 apparait par défaut.
j'aimerai que la cellule soit vide dans un format date si à la source elle l'est aussi.
je bloque aussi sur la recopie d'une autre cellule des fichiers sources (une date aussi) en colonne C du fichier récap.
derniere question dans votre code que signifie a(n, 2) = ExecuteExcel4Macro("'" & chemin & "[" & fichier & "]" & feuille & "'!R5C7")
Merci encore
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
En supposant que la 2ème date se situe en I5 voyez ce fichier (2) et la macro :
VB: 
Sub MAJ()
Dim F As Worksheet, chemin$, fichier$, feuille$, a(), n&, x$
Set F = Feuil1 'CodeName, à adapter
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
feuille = "MaFeuille" 'à adapter
ReDim a(1 To F.Rows.Count, 1 To 3)
'---analyse du dossier---
While fichier <> ""
    n = n + 1
    a(n, 1) = fichier
    x = "'" & chemin & "[" & fichier & "]" & feuille
    a(n, 2) = ExecuteExcel4Macro(x & "'!R5C7"): If a(n, 2) = 0 Then a(n, 2) = ""
    a(n, 3) = ExecuteExcel4Macro(x & "'!R5C9"): If a(n, 3) = 0 Then a(n, 3) = ""
    fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
With F.[A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 3) = a
    .Offset(n).Resize(F.Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
    .EntireColumn.Resize(, 3).AutoFit 'ajustement largeurs
End With
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Faites une recherche sur le web à propos de ExecuteExcel4Macro.
 

Pièces jointes

  • Récap(2).xlsm
    19.1 KB · Affichages: 10
  • Source1.xlsx
    9 KB · Affichages: 8
  • Source2.xlsx
    8.5 KB · Affichages: 7
Vote positif 0 Vote négatif
Solution
L

Le novice

XLDnaute Junior
job75 à dit:
En supposant que la 2ème date se situe en I5 voyez ce fichier (2) et la macro :
VB: 
Sub MAJ()
Dim F As Worksheet, chemin$, fichier$, feuille$, a(), n&, x$
Set F = Feuil1 'CodeName, à adapter
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
feuille = "MaFeuille" 'à adapter
ReDim a(1 To F.Rows.Count, 1 To 3)
'---analyse du dossier---
While fichier <> ""
    n = n + 1
    a(n, 1) = fichier
    x = "'" & chemin & "[" & fichier & "]" & feuille
    a(n, 2) = ExecuteExcel4Macro(x & "'!R5C7"): If a(n, 2) = 0 Then a(n, 2) = ""
    a(n, 3) = ExecuteExcel4Macro(x & "'!R5C9"): If a(n, 3) = 0 Then a(n, 3) = ""
    fichier = Dir 'fichier suivant du dossier
Wend
'---restitution---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
With F.[A2] '1ère cellule de restitution, à adapter
    If n Then .Resize(n, 3) = a
    .Offset(n).Resize(F.Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
    .EntireColumn.Resize(, 3).AutoFit 'ajustement largeurs
End With
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Faites une recherche sur le web à propos de ExecuteExcel4Macro.
Cliquez pour agrandir...
Bonjour encore une fois merci j'ai pu adapter le tout à mon fichier.
mon patron est quelqu'un de très "challengeant" (pour rester correct) aujourd'hui matin il me demande de créer un sous répertoire pour chaque fichier source celui ci portant le même nom que le fichier. du coup le code bloque car il n'est pas prévu d'ouvrir chaque dossier avant de vérifier dans le fichier les fameuses cellules .
 
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
bonjour,
La méthode ADO à utiliser dépend de la version Excel
Cliquez pour agrandir...
je dispose d'Office 2007 sur le pc de la maison et Office 365 sur l'ordi du travail et je ne me souci en aucune minière de la méthode utilisé par Excel pour ouvrir mes fichier XLS, XLSX, Xlsm etc...

de plus vue que Microsoft à abandonné le moteur Jet il n'y qu'une seul façon de ce connecté via ADO!

VB: 
Sub test()
Fichier = "C:MyRep\MyXls.xls"
With CreateObject("AdoDb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    Range("A2").CopyFromRecordset .Execute("SELECT * FROM [Feuille$A1:C12]")
    .Close
End With
End Sub
 
Vote positif 0 Vote négatif
L

Le novice

XLDnaute Junior
je continue mon projet pas à pas avec le peu de connaissance que j'ai et me rend compte de nouvelles difficultés
aujourd'hui je sais récupérer et alimenter mon fichier récap grâce a votre macro qui consulte tous les fichiers crées dans la même répertoire et recopie certaines valeurs
maintenant je bloque sur un nouveau problème c'est que les fichiers ne sont plus à la suite mais chacun dans un sous dossier nommer de la même façon que le fichier source, je n'arrive donc pas à ouvrir chaque sous dossier pour accéder au fichier et récupérer les valeurs.

mon deuxième souci est de pouvoir empêcher l'enregistrement d'un sous dossier et d'un fichier source déjà existant en ajoutant un message si c'est le cas et un autre message de confirmation d'enregistrement si le fichier et dossier sont créés
pour le moment voici mon code
Sub Macro1()

' Macro1 Macro
' Créer le dossier suivant le contenu des cellules U8 et J8
Dim Dossier As String, Fichier As String, Chemin As String
Dossier = Range("U8") & " " & "N°" & "" & Range("J8") & " " & "de" & " " & Hour(Time) & "H" & Minute(Time)
MkDir "Z:\7. Exploitation\1.Direction Exploitation\2. Analyse production\01 Analyse Prod 2020\" & Dossier

' Enregistre le fichier suivant le contenu des cellules U8 et J8
Fichier = Range("U8") & " " & "N°" & "" & Range("J8") & " " & "de" & " " & Hour(Time) & "H" & Minute(Time) & ".xlsm"
Chemin = "Z:\7. Exploitation\1.Direction Exploitation\2. Analyse production\01 Analyse Prod 2020\" & Dossier
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & Fichier & ".xls"

End Sub

merci beaucoup de votre aide
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
549
ManuXZ
M
C
  • Question
Microsoft 365 Extraction de datas dans des fichiers pdf
Réponses
2
Affichages
223
kiki29
kiki29
F
  • Question
XL 2019 Extraire des lignes suivant somme des colonnes pour alimenter un autre tableau
Réponses
1
Affichages
215
fanfan38
fanfan38
Darkopsix
  • Résolu(e)
XL 2021 Récupérer des données de fichiers dons les noms sont renseignés dans des cellules
Réponses
2
Affichages
407
Darkopsix
Darkopsix
J
  • Question
Microsoft 365 Conversion de fichiers word en pdf / VBA
Réponses
1
Affichages
174
kiki29
kiki29
V
  • Question
XL 2021 Implémenter tableau avec des fichiers mis dans un dossier
Réponses
2
Affichages
169
merinos
merinos
J
  • Question
XL 2016 Tableau de bord - report de données
2
Réponses
16
Affichages
408
chris
chris
A
  • Question
Microsoft 365 Besoin d'aide pour fabriquer un tableau de bord
Réponses
2
Affichages
162
nat54
nat54
Magnio
  • Question
XL 2016 Transfert de données d'un tableau en différenciant les libellés
Réponses
8
Affichages
199
Magnio
Magnio
C
  • Question
XL 2016 Faire un tableau de nombres uniques puis associer des images aux cellules
Réponses
4
Affichages
235
DJunqueira
D

Membres actuellement en ligne

14 membres et 97 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 163
Messages
2 085 859
Membres
103 005
dernier inscrit
gilles.hery