Macro listing fichiers dans répertoire et copie cellules

Bonjour,

Je suis tout nouveau dans le forum.

Pour me faciliter la tache, j'ai recherché une macro me permettant de lister les fichiers (avec hyperlien) se trouvant dans un répertoire.

J'ai trouvé la macro "magique" et elle fonctionne à merveille.

Là ou je peine, c'est de pouvoir copier une cellule particulière (nom d'un technicien) dans le listing final. Les fichiers listés sont tous identiques (le nom diffère). En fait c'est un résumé que chaque technicien doit faire lorsqu'un travail est terminé. Et dans la cellule B9, se trouve son prénom que j'aurai voulu récupérer dans le récapitulatif.

Mais un exemple parlant plus que mon blabla, je vous joint le fichier récapitulatif ainsi qu'un exemple de fiche excel que les techniciens doivent remplir.

En espérant avoir été clair et avoir de l'aide pour compléter cette macro.

Cordialement,

Rastanet

Bonjour,

avec le chemin complet du fichier on peut lire la cellule B9 sans ouvrir le fichier,

voici un exemple,

Sub LireCelluleB9()
  Dim Arg As String, Chemin As String, Fichier As String, Feuille As String, cellule As String, résultat As String
  Chemin = "C:\Users\Emmanuel\Documents\BrouillonBis\"
  Fichier = "145_Tests Gre´goire_18.08.17.xlsx"
  Feuille = "Sheet1"
  cellule = Range("B9").Range("A1").Address(, , xlR1C1)
  Arg = "'" & Chemin & "[" & Fichier & "]" & Feuille & "'!" & cellule
  résultat = ExecuteExcel4Macro(Arg)
End Sub

Bonsoir,

Merci pour cet exemple de fonctionnalité. Comment intégrer tout celà pour que celà se fasse de manière automatique - comme le Fichier Excel récapitulatifs avec liens hypertext ?

Devrais-je faire appel à cette nouvelle fonction via une autre feuille / macro ?

Devrais-je créer une macro par feuille excel (chemin complet) ?

Merci de votre aide

Rastanet

Bonjour,

voici un autre exemple sur votre fichier, il faudra adapter à votre répertoire votre fichier "145_Tests Grégoire_18.08.17.xlsx"

la macro et la function sont dans le module1

Bonjour,

Merci pour cette intégration. Mon idée serait aussi de pouvoir récupérer la cellule B9 de tous les fichiers répertoriés et ce de manière automatique. Pour rappel, mon répertoire (contenant les fiches excel des techniciens) possèdent plus de 200 fichiers. Chaque fichier s'intitule : "xxx_NomDeIntervention.xls"

XXX = nombre incrémenté au fur et à mesure.

Mon fichier "Exploreur_Rep_SousRep.xls" scanne le répertoire choisi et liste toutes les fiches avec lien hypertext. Pourrais-t-on en fait intégrer la fonction "LireCellule" dans le processus de listing

Désolé si je n'ai pas été clair au départ.

Merci pour le temps accordé

Bonjour rastanet,

voici ma solution de débutant, ton code integré pour récupérer de manière automatique dans la colonne F la cellule B9 de tous les fichiers répertoriés:

Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Dim MyPath As String
Dim MyName As String

Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
With Sheets("ACCUEIL")
For Each SousDossier In Dossier.SubFolders
    .Cells(I, 2) = SousDossier.Name
    For Each Fichier In SousDossier.Files
    .Cells(I, 3) = Left(Fichier.Name, InStr(Fichier.Name, ".") - 1) 'Nom du fichier avec l'extension
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 3), Address:=SousDossier & "\" & Fichier.Name
    .Cells(I, 4) = Fichier.DateCreated  ' Date de création
    .Cells(I, 5) = Fichier.DateLastModified  ' dernière modification
     I = I + 1
     Next
Next
End With
Range("F16").Select

MyPath = Range("B12") & "\" & Range("B16") & "\"

MyName = Dir(MyPath, vbNormal)
Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
        If (GetAttr(MyPath & MyName) And vbNormal) = vbNormal Then

          ActiveCell.FormulaR1C1 = "='" & MyPath & "[" & MyName & "]Sheet1'!R9C2"
          ActiveCell.Offset(0, 0).Value = ActiveCell.Value

         ActiveCell.Offset(1, 0).Select
        End If
    End If
    MyName = Dir
Loop

End Function

Bonjour à tous,

Rastanet,, peut-tu joindre un fichier avec quelque résultat, j'aimerais voir la disposition des données récoltées avec votre macro pour mieux adapter la macro pour lire la cellule B9.

Un grand merci à Sequoyah. Le code est bon. Juste quelques soucis. Si le listing scanne 2 répertoires en même temps (projet en cours et projets terminés), les noms des techniciens sont affichés uniquement pour le 1er répertoire. La recherche des noms s'arrête à la fin du 1er répertoire

@sabV, voici le fichier avec quelques données récoltées. Bien entendu les données sont fausses et les liens hypertext sont égalements faux.

Merci pour votre aide.

Rastanet

Bonjour,

dans la cellule B9, se trouve son prénom que j'aurai voulu récupérer

ce code devrai faire ce que vous voulez, quel est le problème ?

ActiveCell.FormulaR1C1 = "='" & MyPath & "[" & MyName & "]Sheet1'!R9C2"

Bonjour Rastanet,

Une possible solution (ça marche seulement avec un dossier + deux sous-dossiers):

Function ListeFichier(Chemin As String) As String
    Dim Dossier As Object, SousDossier As Object, Fichier As Object
    Dim MyPath As String
    Dim MyPath2 As String
    Dim MyName As String

    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
    With Sheets("ACCUEIL")
        For Each SousDossier In Dossier.SubFolders
            .Cells(I, 2) = SousDossier.Name
            For Each Fichier In SousDossier.Files
                .Cells(I, 3) = Left(Fichier.Name, InStr(Fichier.Name, ".") - 1) 'Nom du fichier avec l'extension
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 3), Address:=SousDossier & "\" & Fichier.Name
                .Cells(I, 4) = Fichier.DateCreated  ' Date de création
                .Cells(I, 5) = Fichier.DateLastModified  ' dernière modification
                I = I + 1
            Next
        Next
    End With
    Range("F16").Select

    MyPath = Range("B12") & "\" & Range("B16") & "\"

    MyName = Dir(MyPath, vbNormal)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath & MyName) And vbNormal) = vbNormal Then

                ActiveCell.FormulaR1C1 = "='" & MyPath & "[" & MyName & "]Sheet1'!R9C2"
                ActiveCell.Offset(0, 0).Value = ActiveCell.Value

                ActiveCell.Offset(1, 0).Select
            End If
        End If
        MyName = Dir
    Loop

    MyPath2 = Range("B12") & "\" & ActiveCell.Offset(0, -4) & "\"
    MyName = Dir(MyPath2, vbNormal)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath2 & MyName) And vbNormal) = vbNormal Then

                ActiveCell.FormulaR1C1 = "='" & MyPath2 & "[" & MyName & "]Sheet1'!R9C2"
                ActiveCell.Offset(0, 0).Value = ActiveCell.Value

                ActiveCell.Offset(1, 0).Select
            End If
        End If
        MyName = Dir
    Loop

End Function

Bonjour,

Merci de votre réponse. En fait le souci vient du fait que je scanne (à la recherche de fichiers) 2 sous-dossiers et plus.

Si je me limite à 1 seul sous-dossier, je n'ai aucun souci. Mais si je scanne en même temps 2 ou plus, je n'ai pas l'affichage des noms des techniciens.

Ci-joint le fichier avec quelques exemples.

J'ai 2 sous-dossiers : "En Cours" & "Terminés"

"En cours" : scanne OK, nom des techniciens OK

"Terminés" : scanne OK, nom des technciens KO - absents

pour l'exemple, j'ai pris les mêmes fichiers et je les ai dupliqués dans les 2 sous-dossiers, sans aucunes modifications

Merci

Rastanet

Bonjour,

le dernier code que j'ai posté est différent du precedent et dans mon test avec un dossier et deux sous-dossiers le nom des techniciens est affiché de façon correcte. Si on a plus de deux sous-dossier on doit chercher une solution différente.

Bonsoir,

En effet, je n'avais pas vu le post précédent. Il fcontionne à merveille. Encore un très très grand merci.

On va pouvoir mettre ce post comme résolu.

Cordialement

Rechercher des sujets similaires à "macro listing fichiers repertoire copie"