Autres [XL 2007] VBA listage répertoire Nom fichier, Date, Taille

[kif]

Bonjour La Team

Avez vous SVP un exemple de code qui permets de lister un sous répertoire (fixe) de mon workbook, me permettant de recuperer à partir de la cellule C15 la liste des fichiers présents avec leur taille et date de création ?

... de mon workbook, le sous répertoire fixe sera toujours /2-Client/

Merci d'avance de votre support

Salutations

Franck

 

[kif]

Merci Jean Marie c'est du rapide merci beaucoup


Je l'ai coller sur un event click bouton,

Par contre à priori le transpose ne se fais pas ? j'ai rien sur la cellule C15 ?

-----------------------------------------------
Private Sub CommandButton1_Click()
Dim T(), Rep$, sfilename$, dl&, n&
Rep = ThisWorkbook.Path & "\2-Client"
If Dir(Rep, vbDirectory) = "" Then MsgBox "Dossier inexistant", 16: Exit Sub
sfilename = Dir(Rep & "\*.xls*")
Do While sfilename <> ""
n = n + 1: ReDim Preserve T(1 To 2, 1 To n)
T(1, n) = sfilename
T(2, n) = FileDateTime(Rep & "\" & sfilename)
sfilename = Dir
Loop
With Sheets("Index Docs")
With .Range("C15")
.Resize(, 2).ClearContents
If n > 0 Then .Resize(n, 2) = Application.Transpose(T)
End With
End With
---------------------------------------------------------

 

[ChTi160]

Bonjour,

Pour joindre ton Code tu as des balises dans la Barre soit "</>"

Jean marie

 

[sylvanu]

Bonjour Kif, Chti,
Une variation légère avec la taille.

 

[patricktoulon]

Bonjour
la solutions de @ChTi160 fonctionne très bien
je modifie quand même la taille car on peut être en "KO "ou "MO"
je modifie le clearcontents aussi
et je supprime un with

Private Sub CommandButton1_Click()
    Dim T(), Rep$, sfilename$, dl&, n&
    Rep = ThisWorkbook.Path & "\2-Client"
    If Dir(Rep, vbDirectory) = "" Then MsgBox "Dossier inexistant", 16: Exit Sub
    sfilename = Dir(Rep & "\*.xls*")
    Do While sfilename <> ""
        n = n + 1: ReDim Preserve T(1 To 3, 1 To n)
        T(1, n) = sfilename
        T(2, n) = FileDateTime(Rep & "\" & sfilename)
        T(3, n) = FileLen(Rep & "\" & sfilename) / 1000 & IIf(FileLen(Rep & "\" & sfilename) / 1000 < 1000, " KO", " MO")
        sfilename = Dir
    Loop
    With Sheets("Index Docs").Range("C15")
        .CurrentRegion.ClearContents  '<<<Attention!!!!!si autres tableau trop proche choisir autre méthodes >>> 
        If n > 0 Then .Resize(n, 3) = Application.Transpose(T)
    End With
End Sub

 

[patricktoulon]

re
et si on devais garder la colonne 3 en numerique mais garder l'indicatif de poids
on formate dans une sub boucle avec numberformat comme ça les poids sont numerique mais on vois la tranche de poids

Private Sub CommandButton1_Click()
    Dim T(), Rep$, sfilename$, dl&, n&
    Rep = ThisWorkbook.Path & "\2-Client"
    If Dir(Rep, vbDirectory) = "" Then MsgBox "Dossier inexistant", 16: Exit Sub
    sfilename = Dir(Rep & "\*.xls*")
    Do While sfilename <> ""
        n = n + 1: ReDim Preserve T(1 To 3, 1 To n)
        T(1, n) = sfilename
        T(2, n) = FileDateTime(Rep & "\" & sfilename)
        T(3, n) = FileLen(Rep & "\" & sfilename) / 1000    '& IIf(FileLen(Rep & "\" & sfilename) / 1000 < 1000, " KO", " MO")
        sfilename = Dir
    Loop
    With Sheets("Index Docs").Range("C15")
        .CurrentRegion.ClearContents
        If n > 0 Then .Resize(n, 3) = Application.Transpose(T)
        With .Resize(n, 3)
            For i = 1 To n
                .Cells(i, 3).NumberFormat = "#0.00" & IIf(.Cells(i, 3) < 1000, " KO", " MO")
            Next
        End With
    End With
End Sub

 

[kif]

Whoaa c'est cool c'est noël avant l'heure les gars merci beaucoup à vous

je teste

 

[kif]

Hummmm j'ai une erreur "1004 définie par l'application ou par l'objet" sur le "With .Resize(n, 3)"

 

[patricktoulon]

re
ouaisp!! j'evite une erreur si n=0 et je met le tout dans un seul bloc With

Private Sub CommandButton1_Click()
    Dim T(), Rep$, sfilename$, dl&, n&
    Rep = ThisWorkbook.Path & "\2-Client"
    If Dir(Rep, vbDirectory) = "" Then MsgBox "Dossier inexistant", 16: Exit Sub
    sfilename = Dir(Rep & "\*.xls*")
    Do While sfilename <> ""
        n = n + 1: ReDim Preserve T(1 To 3, 1 To n)
        T(1, n) = sfilename
        T(2, n) = FileDateTime(Rep & "\" & sfilename)
        T(3, n) = FileLen(Rep & "\" & sfilename) / 1000
        sfilename = Dir
    Loop
    With Sheets("Index Docs").Range("C15")
        .CurrentRegion.ClearContents
        If n > 0 Then
            .Resize(n, 3) = Application.Transpose(T)
            For i = 1 To n
                .resize(n,3).Cells(i, 3).NumberFormat = "#0.00" & IIf(.Cells(i, 3) < 1000, " Ko", " Mo")
            Next
       else
 msgbox "n=0 donc il y a un soucis dans l’accès au dossier ou il n'est pas là ou vous pensez"
 End If
    End With
End Sub

si n= 0 et que tu a le msgbox a mon avis c'est que le fichier macro n'est pas dans le dossier ou se trouve le dossier "2_client...."mais dans le dossier parent ou qu'il n'y a pas de fichier dans ce dossier

 

[kif]

Oui j'ai le message

Peux être l’accès réseau ou la structure des répertoire je teste....

 

[kif]

déjà c'est pas les droits à l’accès réseau car en local c'est idem

 

[patricktoulon]

bon ben voilà on avance
tiens teste ça dans un module standard
si tu n'a pas les deux nom entre guillemets c'est que ton dossier n'est pas là ou tu crois

Sub test()
 Rep = ThisWorkbook.Path
 d1 = Rep
 d2 = Rep & "\2-Client"
MsgBox "le dossier du classeur macro" & vbCrLf & Chr(34) & Dir(d1, vbDirectory) & Chr(34) & vbCrLf & vbCrLf & "le dossier recherché" & _
vbCrLf & Chr(34) & Dir(d2, vbDirectory) & Chr(34)
End Sub

 

[kif]

Ok test du Msgbox

le dossier macro : "1-Accueil-Revue de design"
le dossier recherché : "2-Client"

 

[kif]

Petite modif de ton code : sfilename = Dir(Rep & "\*.*") car c'est tout type de fichiers que je liste

 

[patricktoulon]

a ben alors tu n'a pas de fichier "*xls*" à l’intérieur