VBA Excel - Lister fichiers & caractéristique Fermé

Question

Bonjour,

J’ai une tâche à faire pour mon boulot d’étudiante en entreprise, mais comme c’est long, je voudrais utiliser une macro avec VBA pour simplifier la tâche.

En fait je dois lister dans un classeur excel tous les powerpoint (.ppt) qui sont dans les dossiers et sous-dossiers du réseau (il y en a des milliers…), avec le titre, l’emplacement (en tant que lien hypertexte si possible), la taille, et le nombre de pages (de diapos) :
Colonne A : Titre
Colonne B : Nombre de pages
Colonne C : Taille
Colonne D : Emplacement (nom complet et détaillé, mais en lien hypertexte en plus)

J’ai découvert hier VBA, et à l’aide des forums j’ai concocté cela : 
______________________________________________________
Sub Importationppt()
    Dim ScanFic As Office.FileSearch
    Dim NomFic  As Variant
    Dim Diag    As String
    Dim Nbr     As Long
    Dim I       As Long
    Set ScanFic = Application.FileSearch
        With ScanFic
        .NewSearch
        .LookIn = "K:\Dept LIAISONS\DLS\Dossier LS"
        .SearchSubFolders = True
        .Filename = "ppt"
        .MatchTextExactly = True
        .FileType = msoFileTypeAllFiles
        Nbr = .Execute
        Diag = Format(Nbr, "0 ""fichiers trouvés""")
                I = 0
        For Each NomFic In .FoundFiles
            I = I + 1
            Sheets("Feuil1").Cells(I, 1).Value = NomFic ' adapter le nom de la feuille
        Next
                MsgBox Diag
            End With
        End Sub
______________________________________________________
ça me met en fait simplement la liste des emplacements dans la colonne A… c’est tout mais déjà pas mal  pour une débutante !
J’ai vu dans l’aide de Visual Basic, que DocumentProperty que l’on pouvait ajouter tout ce que je voulais, mais j’ai aucune idée de comment ça s’écrit dans le code… et alors pour paramétrer aussi mes demandes dans les colonnes correspondantes, c’est vraiment au-dessus de mes capacités de programmatrice ! ;-)

Si quelqu’un d’expérimenter pouvait m’écrire le code correspondant, ça me sauverait vraiment la vie ! sinon ce sera à la main… plus fastidieux je ne connaît pas !
Et en plus c’est pour la semaine du 11/08/08….. HELP !!
Merci d’avance !

Delphine

lucoli · Answer

Bonjour,
Sice n'est pas trop tard ou si le sujet vous intéresse toujours, je suis prête à vous aider car je suis en retraite et j'ai fait beaucoup de VBA
Cordialement

liryc · Answer

Bonjour, Je dessinateur industriel sur Solid Egde et j'aurais besoins de lister les plans que j'ai créé (fichier.dft). Je suis plus que novice dans le domaine VBA mais j'ai réussit à "créer" un code qui : - liste les fichiers dans le dossier et sous dossiers "Z:\Mon travail\Bibliothèque\Produits intérieurs\EMH Trolleys\CH200" - filtre le type de fichier suivant indication dans la cellule F19 (en l'occurrence .dft) - indique la date de création - ajout le lien hypertexte ... mais ayant des milliers de fichiers à traiter, c'est beaucoup trop long !!! emps Il y aurait il un moyen de réduire le t de traitement ? (Sachant que je ne filtrer que les fichiers type .dft) Voici le code ne question : Option Explicit Sub ScanClasseurs() Dim Dossier As Object, Fichier As Object Dim Chemin As String, CeFichier As String, ExtFichier As String Dim TabDossiers As Variant Dim L As Long, D As Long Dim pos As Byte Dim InitSB As Boolean InitSB = Application.DisplayStatusBar Application.DisplayStatusBar = True Chemin = "Z:\Mon travail\Bibliothèque\Produits intérieurs\EMH Trolleys\CH200" If Chemin = "" Then Exit Sub Application.ScreenUpdating = False ThisWorkbook.Sheets("ListeDFT").Range("A2:C65536").Delete Shift:=xlUp CeFichier = ThisWorkbook.Name ExtFichier = UCase(Trim(ThisWorkbook.Sheets("ListeDFT").Range("Extension").Text)) L = 1 'Création du tableau des sous-dossiers existants TabDossiers = lstDossiers(Chemin, True) For D = 1 To UBound(TabDossiers) 'Chemin du dossier (ou sous-dossier) à analyser Chemin = TabDossiers(D) If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\" 'Analyse du dossier (ou sous-dossier) Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) For Each Fichier In Dossier.Files If Fichier.Name <> CeFichier Then If ExtFichier = "" Or UCase(Right(Fichier.Name, 3)) = ExtFichier Then 'Liste les fichiers L = L + 1 ' Application.StatusBar = "ligne traitée : " & L 'MAJ feuille résultats With ThisWorkbook.Sheets("ListeDFT") .Cells(L, 1).Value = Chemin .Hyperlinks.Add Anchor:=.Cells(L, 2), Address:=Chemin & Fichier.Name, _ TextToDisplay:=Fichier.Name .Cells(L, 3).Value = Fichier.DateCreated End With End If End If Next Next D Columns("B:B").Select Range("A1:C65536").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range("A1").Select Set Dossier = Nothing 'Rétablit l'alerte de lien éventuelle dans les options Excel Application.ScreenUpdating = True MsgBox L - 1 & " fichiers trouvés !" Application.StatusBar = False 'Réinintialise le mode d'affichage de la barre. Application.DisplayStatusBar = InitSB End Sub Private Function lstDossiers(Chemin As String, Optional Debut As Boolean) As Variant Dim Dossier As Object, SD As Object, D As Object Static TabTemp() As String If Debut Then ReDim TabTemp(1 To 1) TabTemp(1) = Chemin End If Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) 'examen du dossier courant For Each D In Dossier.subfolders ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1) TabTemp(UBound(TabTemp)) = D.Path Next 'Traitement récursif des sous-dossiers (d'après un code de F.Sigonneau) For Each SD In Dossier.subfolders lstDossiers SD.Path Next SD lstDossiers = TabTemp() Set Dossier = Nothing End Function Merci d'avance pour vos reponses