Problème récup contenu cellules classeurs fermés

Bonjour

Voici mon souci.

Je souhaite récupérer dans mon classeur "Tri" le contenu de plusieurs (nombreux) classeurs fermés:

• Le nom de chaque classeur sera copié en colonne A de mon classeur "Tri"
• La cellule A3 de chaque classeur sera copiée en colonne B de mon classeur "Tri"

Voici le code que j'utilise:

Option Explicit

Sub ImporterDates()
Dim objShell As Object
Dim objFolder As Object
Dim Chemin As String
Dim Fichier As String

    Set objShell = CreateObject("Shell.Application")
'Ouvre une fenêtre Window pour sélectionner le dossier
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
'Si l'utilisateur annule sans choisir
If objFolder Is Nothing Then
 'message
    MsgBox "Abandon opérateur", vbCritical, "Annulation"
 'sinon
Else
 'Chemin = répertoire choisi
    Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
'Choix du 1er fichier
    Fichier = Dir(Chemin & "*.xls")
'on boucle sur tous les fichiers excel du répertoire choisi
    Do While Len(Fichier) > 0
      If Fichier <> ThisWorkbook.Name Then
            With Sheets("Feuil1")
'Inscrit le nom des fichiers en colonne A
                Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Fichier
'Inscrit le contenu de la cellule A3 en B
                Sheets("Feuil1").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = "='" & "[" & Fichier & "]Feuil1'!A3"
            End With
        End If
        Fichier = Dir()
    Loop
End If
End Sub

Lorsque je lance la macro une fenêtre Windows me permet de sélectionner le chemin du dossier contenant les classeurs à traiter.

Après sélection le nom du premier classeur est correctement collé en cellule A2 de mon classeur Tri.

Ensuite ça se gâte, une nouvelle fenêtre Windows me demande de sélectionner les classeurs.

Si je sélectionne le premier son contenu en cellule A3 est correctement copié en cellule B2 de mon classeur "Tri".

Si au contraire je clique sur annuler, la cellule A2 de mon classeur "Tri" reçois un #REF.

Dans les deux cas la fenêtre Windows revient et le cycle "non désiré" se poursuit.

Par contre le traitement du dernier classeur se fait complètement sans intervention manuelle.

Pour résumer:

La copie des noms de classeurs se déroule normalement.

La copie de chaque cellules A3 oblige à indiquer à chaque fois le chemin complet

SAUF pour le dernier classeur qui est traité normalement.

Une remarque

Lorsque je vais dans le dossier (sans passer par la macro) contenant les classeurs à traiter et que j'ouvre et referme chaque classeur et qu'ensuite je lance ma macro, tout fonctionne pour chaque classeurs (je récupère le nom du fichier et la cellule A3 de chaque) sans avoir à redonner systématiquement le chemin des classeurs.

Je fais mes essais avec seulement 6 fichiers heureusement, je me vois mal appliquer cette méthode sur 1000 classeurs.

Je joins un classeur montrant ce que j'obtiens si je clique sur Annuler dans chaque fenêtres Windows.

Merci pour tout aide

Bonjour,

essaie en ajoutant le chemin dans ta formule voir ci-dessous

Sheets("Feuil1").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = "='"  & chemin & "[" & Fichier & "]Feuil1'!A3"

Option Explicit

Sub ImporterDates()
Dim objShell As Object
Dim objFolder As Object
Dim Chemin As String
Dim Fichier As String

    Set objShell = CreateObject("Shell.Application")
'Ouvre une fenêtre Window pour sélectionner le dossier
   Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
'Si l'utilisateur annule sans choisir
If objFolder Is Nothing Then
 'message
   MsgBox "Abandon opérateur", vbCritical, "Annulation"
 'sinon
Else
 'Chemin = répertoire choisi
   Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
'Choix du 1er fichier
   Fichier = Dir(Chemin & "*.xls")
'on boucle sur tous les fichiers excel du répertoire choisi
   Do While Len(Fichier) > 0
      If Fichier <> ThisWorkbook.Name Then
            With Sheets("Feuil1")
'Inscrit le nom des fichiers en colonne A
               Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Fichier
'Inscrit le contenu de la cellule A3 en B
               Sheets("Feuil1").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = "='"  & chemin & "[" & Fichier & "]Feuil1'!A3"
            End With
        End If
        Fichier = Dir()
    Loop
End If
End Sub
 

Bonjour

h2so4 ta solution marche du tonnerre .

Je t'envoie un grand merci.