Récupérer des informations via un fichier

Version imprimable

03/06/2010, 12h20
chubak62

Récupérer des informations via un fichier

Bonjour à tous,

étant novice (ou presque) en VBA car je ne l'utilise qu'en période de stage (dans laquelle je suis actuellemnt) je me peret de venir poster ici pour demander des renseignements :

Je voudrais créer un fichier excel qui se compose comme suit :

(Colonne A) Nom du dossier (B)nom du document (C)date création (D)date modification (E)Lien

et je voudrais qu'en fonction du lein et donc du document, les données de ce fichier word ou excel soit extraite automatiquement

Par exemple pour un fichier word dont le chemin d'accès est C:/Sports/dopage.doc crée le 12/05/2010 et modifié le 13/05/2010 on retrouverez ces données dans chacune des colonne indiquée. (A)C:/sports (B)dopage (C)12/05/2010 (D)13/05/2010 (E)

Je ne sais pas si cela est possible, c'est pourquoi je vous demande de l'aide sur le sujet.

Merci!

Bien à vous,

Yoann

Merci à vous!

une proposition

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub FileList()
Dim Chem As String, Rep As String, Fich As String, FichComp
Dim nLig As Integer, i As Integer
Dim tablo() As String
 
Chem = "C:\Documents and Settings\" 'Path initial
ReDim tablo(1)
tablo(0) = Chem: i = 1
'Recherche les répertoires (1er niveau) dans Chem
Rep = Dir(Chem, vbDirectory)
Do While Rep <> ""
    If Rep <> "." And Rep <> ".." Then
        If (GetAttr(Chem & Rep) And vbDirectory) = vbDirectory Then
            ReDim Preserve tablo(i + 1)
            tablo(i) = Chem & Rep
            i = i + 1
        End If
    End If
    Rep = Dir
Loop
'Pour Chaque répertoire, lister les fichiers répondant au critère DOC_DOCX_XLS_JPG
With Sheets("Feuil2")   'à adapter
    For i = 0 To UBound(tablo)
        Fich = Dir(tablo(i) & "\", vbNormal)
        Do While Fich <> ""
            If InStr(".DOC_DOCX_.XLS_.MBD_.JPG_.PDF", UCase(Right(Fich, 4))) > 0 Then 'à adapter selon les extensions de fichier à chercher
                nLig = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                .Range("A" & nLig).Value = tablo(i)
                .Range("B" & nLig).Value = Fich
            End If
            Fich = Dir
        Loop
    Next i
    For i = 2 To nLig
        Rep = .Range("A" & i).Value
        Fich = .Range("B" & i).Value
        FichComp = Rep & "/" & Fich
        .Range("C" & i).Value = FileDateTime(FichComp)
        .Hyperlinks.Add anchor:=.Range("D" & i), Address:=FichComp
    Next i
End With
End Sub

04/06/2010, 10h37
chubak62

Merci pour ta proposition,

Je teste cela immédiatement, je fais les réajustements et si problème il y a, je vous en informerez.

Merci.

Ci joint autre proposition plus complète

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
'/!\ Activer la référence (Microsoft Scripting RunTime)
 
Dim Fso As Scripting.FileSystemObject
Dim FileItem As Scripting.File
Dim Chem As String, Rep As String, Fich As String
Dim nLig As Integer, i As Integer
Dim tablo() As String
 
Application.ScreenUpdating = False
Chem = "C:\Documents and Settings\POSTE F\Bureau\" 'Path initial
ReDim tablo(1)
tablo(0) = Chem: i = 1
'Recherche les répertoires (1er niveau) dans Chem
Rep = Dir(Chem, vbDirectory)
Do While Rep <> ""
    If Rep <> "." And Rep <> ".." Then
        If (GetAttr(Chem & Rep) And vbDirectory) = vbDirectory Then
            ReDim Preserve tablo(i + 1)
            tablo(i) = Chem & Rep
            i = i + 1
        End If
    End If
    Rep = Dir
Loop
 
With Sheets("Feuil2")   'à adapter
.Cells.ClearContents    ' à supprimer éventuellement
Set Fso = CreateObject("Scripting.FileSystemObject")
    For i = 0 To UBound(tablo)
        Fich = Dir(tablo(i) & "\*.*")
        Do While Fich <> ""
            If InStr(".DOC_.DOCX_.XLS_.MDB_.PDF_.BMP_.JPG", UCase(Right(Fich, 4))) > 0 Then
                On Error Resume Next
                Set FileItem = Fso.GetFile(tablo(i) & "\" & Fich)
                nLig = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Range("A" & nLig).Value = FileItem.ParentFolder
                .Range("B" & nLig).Value = FileItem.Name
                .Hyperlinks.Add anchor:=.Range("C" & nLig), Address:=FileItem.Path
                .Range("D" & nLig).Value = FileItem.DateCreated
                .Range("E" & nLig).Value = FileItem.DateLastModified
                On Error GoTo 0
                Set FileItem = Nothing
            End If
            Fich = Dir
        Loop
    Next i
    Set Fso = Nothing
End With
End Sub

Edit: Oups, méthode plus complète dans la FAQ http://excel.developpez.com/faq/inde...riptingRuntime