Autres Gestion_Fichiers

VIARD · 18 Octobre 2021

Bonjour à toutes et tous

Voici un petit utilitaire, qui peut rendre service à tous.
J'ai utilisé la fonction de "Walkenbach"
Il suffit de choisir le répertoire à explorer.
Bon usage à tous.

A+ Jean-Paul

Bernard_XLD · 24 Octobre 2021

re,

deuxième petite modif proposée, on passe par des tableaux vb plutôt que d'écrire dans chaque cellule, c'est beaucoup plus rapide sur un grand nombre de fichiers.

Bien cordialement, @+

VB:

'===========================
Sub Liste_des_Fichiers()
Dim Msg$, Directory$, Nb%
Dim i As Long, Ext$, Ex$
Dim Dossier As Object
Dim Fichier As Object
Dim Tablo(), Tablo2()

    Msg = "Sélectionnez un emplacement contenant les fichiers que vous souhaitez lister."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
'------- Insérer en-têtes ------
    i = 2
    Range("A:D").ClearContents
    Cells(i, 1) = "Nom de fichier"
    Cells(i, 2) = "Taille"
    Cells(i, 3) = "Date"
    Range("A1:D2").Font.Bold = True: Range("C:C").ColumnWidth = 16 ': Exit Sub
    Range("A1:D2").HorizontalAlignment = xlCenter
    Range("A2:D2").Interior.ColorIndex = 6: Range("A1").Interior.ColorIndex = 44
    'On Error Resume Next
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Directory)
'--------- Choix Extention --------
Ex = InputBox("Choix extention :" & Chr(10) & ".xls, .doc, .PDF, .txt, .jpg, .avi, .zip, .gif" _
& Chr(10) & ".bmp, .ico, .mid, .mp3, .wma, .xlsm, .xlsx, .docx" _
& Chr(10) & "Ne pas oublier le point" _
& Chr(10) & "Pour tout lister extention vide --> valider directement", "EXTENTION")
'------- Affichage Fichiers -------
       
        i = 0
        For Each Fichier In Dossier.Files
            If Fichier.Name Like "*" & Ex Then
                i = i + 1
                ReDim Preserve Tablo(1 To 3, 1 To i)
                Tablo(1, i) = Fichier.Name: Tablo(2, i) = Fichier.Size: Tablo(3, i) = Fichier.datecreated
            End If
            Cells(2, 4) = "Q = " & i - 2
        Next Fichier
        ReDim Tablo2(LBound(Tablo, 2) To UBound(Tablo, 2), 1 To 3)
        For i = LBound(Tablo, 2) To UBound(Tablo, 2)
            Tablo2(i, 1) = Tablo(1, i): Tablo2(i, 2) = Tablo(2, i): Tablo2(i, 3) = Tablo(3, i)
        Next i
        Range("A3:C" & 3 + UBound(Tablo, 2) - LBound(Tablo, 2)).Value = Tablo2
        Range("A1").Value = Directory
        Columns("A:C").EntireColumn.AutoFit
End Sub
'============================

VIARD · 24 Octobre 2021

Bonjour Yeahou, Cp4 et à tous

Très judicieux, je vais appliquer la recette.
Merci
A+ Jean-Paul

Bernard_XLD · 24 Octobre 2021

Re,

pour le fun, une variante plus rapide encore avec transpose mais limitée à 65536 fichiers

Bien cordialement, @+

Code:

'===========================
Sub Liste_des_Fichiers()
Dim Msg$, Directory$, Nb%
Dim i As Long, Ext$, Ex$
Dim Dossier As Object
Dim Fichier As Object
Dim Tablo()

    Msg = "Sélectionnez un emplacement contenant les fichiers que vous souhaitez lister."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
'------- Insérer en-têtes ------
    i = 2
    Range("A:D").ClearContents
    Cells(i, 1) = "Nom de fichier"
    Cells(i, 2) = "Taille"
    Cells(i, 3) = "Date"
    Range("A1:D2").Font.Bold = True: Range("C:C").ColumnWidth = 16 ': Exit Sub
    Range("A1:D2").HorizontalAlignment = xlCenter
    Range("A2:D2").Interior.ColorIndex = 6: Range("A1").Interior.ColorIndex = 44
    'On Error Resume Next
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Directory)
'--------- Choix Extention --------
Ex = InputBox("Choix extention :" & Chr(10) & ".xls, .doc, .PDF, .txt, .jpg, .avi, .zip, .gif" _
& Chr(10) & ".bmp, .ico, .mid, .mp3, .wma, .xlsm, .xlsx, .docx" _
& Chr(10) & "Ne pas oublier le point" _
& Chr(10) & "Pour tout lister extention vide --> valider directement", "EXTENTION")
'------- Affichage Fichiers -------
       
        i = 0
        For Each Fichier In Dossier.Files
            If Fichier.Name Like "*" & Ex Then
                i = i + 1
                ReDim Preserve Tablo(1 To 3, 1 To i)
                Tablo(1, i) = Fichier.Name: Tablo(2, i) = Fichier.Size: Tablo(3, i) = Fichier.datecreated
            End If
            Cells(2, 4) = "Q = " & i - 2
        Next Fichier
        Range("A3:C" & 3 + UBound(Tablo, 2) - LBound(Tablo, 2)).Value = Application.Transpose(Tablo)
        Range("A1").Value = Directory
        Columns("A:C").EntireColumn.AutoFit
End Sub
'============================

Bernard_XLD · 24 Octobre 2021

Re,

une proposition de modif pour ajouter les types de fichiers et ajouter des filtres auto.
[édition: code modifié, mieux en variant pour les tableaux]

Bien cordialement, @+

Code:

'===========================
Sub Liste_des_Fichiers()
Dim Msg$, Directory$, Nb%
Dim i As Long, Ext$, Ex$
Dim Dossier As Object
Dim Fichier As Object
Dim Tablo(), Tablo2()

    Msg = "Sélectionnez un emplacement contenant les fichiers que vous souhaitez lister."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
'------- Insérer en-têtes ------
    i = 2
    ActiveSheet.AutoFilterMode = False
    Range("A:D").ClearContents
    Cells(i, 1) = "Nom de fichier"
    Cells(i, 2) = "Taille"
    Cells(i, 3) = "Date"
    Cells(i, 4) = "Type"
    With Range("A1:E2")
        .Font.Bold = True: Range("C:C").ColumnWidth = 16 ': Exit Sub
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 6: Range("A1").Interior.ColorIndex = 44
    End With
    On Error Resume Next
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Directory)
'--------- Choix Extention --------
Ex = InputBox("Choix extention :" & Chr(10) & ".xls, .doc, .PDF, .txt, .jpg, .avi, .zip, .gif" _
& Chr(10) & ".bmp, .ico, .mid, .mp3, .wma, .xlsm, .xlsx, .docx" _
& Chr(10) & "Ne pas oublier le point" _
& Chr(10) & "Pour tout lister extention vide --> valider directement", "EXTENTION")
'------- Affichage Fichiers -------
       
        i = 0
        For Each Fichier In Dossier.Files
            If Fichier.Name Like "*" & Ex Then
                i = i + 1
                ReDim Preserve Tablo(1 To 4, 1 To i)
                Tablo(1, i) = Fichier.Name: Tablo(2, i) = Fichier.Size: Tablo(3, i) = Fichier.datecreated:: Tablo(4, i) = Fichier.Type
            End If
            Cells(2, 5) = "Q = " & i - 2
        Next Fichier
        ReDim Tablo2(LBound(Tablo, 2) To UBound(Tablo, 2), 1 To 4)
        For i = LBound(Tablo, 2) To UBound(Tablo, 2)
            Tablo2(i, 1) = Tablo(1, i): Tablo2(i, 2) = Tablo(2, i): Tablo2(i, 3) = Tablo(3, i): Tablo2(i, 4) = Tablo(4, i)
        Next i
        Range("A3:D" & 3 + UBound(Tablo, 2) - LBound(Tablo, 2)).Value = Tablo2
        Range("A1").Value = Directory
        Columns("A:E").EntireColumn.AutoFit
        Range("A2:D2").AutoFilter
End Sub

VIARD · 24 Octobre 2021

Re Bonjour Yeahou

Je n'ai pas vu t'as deuxième intervention.
le passage par tableau est super, je l'utilise mais pas assez.
et te remercie infiniment pour ça. c'est vraiment une modif intéressante

Salutation Jean-Paul

Bernard_XLD · 24 Octobre 2021

Re,

et une petite dernière pour la route, ajout de la date de dernière modification, j'utilise souvent.

Bonne journée

VB:

'===========================
Sub Liste_des_Fichiers()
Dim Msg$, Directory$, Nb%
Dim i As Long, Ext$, Ex$
Dim Dossier As Object
Dim Fichier As Object
Dim Tablo(), Tablo2()

    Msg = "Sélectionnez un emplacement contenant les fichiers que vous souhaitez lister."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
'------- Insérer en-têtes ------
    i = 2
    ActiveSheet.AutoFilterMode = False
    Range("A:F").ClearContents
    Cells(i, 1) = "Nom de fichier"
    Cells(i, 2) = "Taille"
    Cells(i, 3) = "Date de création"
    Cells(i, 4) = "Date de dernière modification"
    Cells(i, 5) = "Type"
    With Range("A1:F2")
        .Font.Bold = True: Range("C:C").ColumnWidth = 16 ': Exit Sub
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 6: Range("A1").Interior.ColorIndex = 44
    End With
    On Error Resume Next
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Directory)
'--------- Choix Extention --------
Ex = InputBox("Choix extention :" & Chr(10) & ".xls, .doc, .PDF, .txt, .jpg, .avi, .zip, .gif" _
& Chr(10) & ".bmp, .ico, .mid, .mp3, .wma, .xlsm, .xlsx, .docx" _
& Chr(10) & "Ne pas oublier le point" _
& Chr(10) & "Pour tout lister extention vide --> valider directement", "EXTENTION")
'------- Affichage Fichiers -------
      
        i = 0
        For Each Fichier In Dossier.Files
            If Fichier.Name Like "*" & Ex Then
                i = i + 1
                ReDim Preserve Tablo(1 To 5, 1 To i)
                Tablo(1, i) = Fichier.Name: Tablo(2, i) = Fichier.Size: Tablo(3, i) = Fichier.datecreated:: Tablo(4, i) = Fichier.datelastmodified: Tablo(5, i) = Fichier.Type
            End If
            Cells(2, 6) = "Q = " & i - 2
        Next Fichier
        ReDim Tablo2(LBound(Tablo, 2) To UBound(Tablo, 2), 1 To 5)
        For i = LBound(Tablo, 2) To UBound(Tablo, 2)
            Tablo2(i, 1) = Tablo(1, i): Tablo2(i, 2) = Tablo(2, i): Tablo2(i, 3) = Tablo(3, i): Tablo2(i, 4) = Tablo(4, i):: Tablo2(i, 5) = Tablo(5, i)
        Next i
        Range("A3:E" & 3 + UBound(Tablo, 2) - LBound(Tablo, 2)).Value = Tablo2
        Range("A1").Value = Directory
        Range("A2:E2").AutoFilter
        Columns("A:F").EntireColumn.AutoFit
End Sub
'============================
'--> Fonction de Walkenbach
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

'---------- Dossier racine = Bureau ---------
    bInfo.pidlRoot = 0&
'------ Titre dans la boîte de dialogue -----
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Sélectionnez un dossier."
    Else
        bInfo.lpszTitle = Msg
    End If
'-------- Type de dossier à retourner -------
    bInfo.ulFlags = &H1
'------- Afficher la boîte de dialogue ------
    x = SHBrowseForFolder(bInfo)
'---------- Afficher le résultat ------------
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function
'==========================

Bernard_XLD · 24 Octobre 2021

re,

VIARD à dit:
Re Bonjour Yeahou

Je n'ai pas vu t'as deuxième intervention.
le passage par tableau est super, je l'utilise mais pas assez.
et te remercie infiniment pour ça. c'est vraiment une modif intéressante

Salutation Jean-Paul

De rien, cela m'a fait un moment de détente.

Bonne continuation

fanch55 · 24 Octobre 2021

Bonjour à tous,
pour ceux que cela intéresse, dernière version de @Yeahou autorisant le 64 bits .
Nota: le timestamp de modification sur les fichiers en réseau est en format Utc et non local ...

Effectuez une recherche sur Excel Downloads...

Autres Gestion_Fichiers

VIARD

XLDnaute Impliqué

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

VIARD

XLDnaute Impliqué

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Pièces jointes

VIARD

XLDnaute Impliqué

Bernard_XLD

XLDnaute Barbatruc

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums