VBA Excel - Lister fichiers & caractéristique

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

VBA Excel - Lister fichiers & caractéristique

2 réponses

Discussions similaires

Newsletters