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

kif

XLDnaute Occasionnel
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

XLDnaute Occasionnel
Merci Jean Marie c'est du rapide :cool: 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
---------------------------------------------------------
 

patricktoulon

XLDnaute Barbatruc
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
VB:
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
demo.gif
 

patricktoulon

XLDnaute Barbatruc
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
VB:
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
demo.gif
 

patricktoulon

XLDnaute Barbatruc
re
ouaisp!!;) j'evite une erreur si n=0 et je met le tout dans un seul bloc With
VB:
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
 

patricktoulon

XLDnaute Barbatruc
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
VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
312 931
Messages
2 093 721
Membres
105 796
dernier inscrit
Max...26