Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Nombre et taille de tous les classeurs Excel de mon ordi !

Nombre et taille de tous les classeurs Excel de mon ordi !

18 réponses
Avatar
garnote
Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:\" 'ou "D:\Données\ ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:\Données\"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "\" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
MichDenis
Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" a écrit dans le message de groupe de discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge
Avatar
garnote
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis" a écrit dans le message de news:

Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" a écrit dans le message de groupe de
discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge



Avatar
garnote
C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" a écrit dans le message de news:
%
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis" a écrit dans le message de news:

Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" a écrit dans le message de groupe de
discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge







Avatar
MichDenis
Si tu ne veux que les fichiers soient dans excel, que ta volonté soit faite !
;-)

dir c:*.xls* /s/n/o >c:Test.xls

à la limite, tu peux même actionner la commande à partir d'une macro :
'----------------------------------
Sub Afficher_les_Fichiers_Excel()
Shell "command.com /c dir c:*.xls /s/b >C:test.xls", vbHide
End Sub
'----------------------------------

Dis moi, quoi vouloir de plus ?
;-))




"garnote" a écrit dans le message de groupe de discussion :

C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" a écrit dans le message de news:
%
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis" a écrit dans le message de news:

Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" a écrit dans le message de groupe de
discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge







Avatar
garnote
> Dis moi, quoi vouloir de plus ?


Rien pantoute :-)
Par contre, si tu fais une tournée provinciale Excel
pour dépatouiller les pataugeurs de mon espèce,
n'oublie pas de passer par Québec; je serai aux
premières loges !




"MichDenis" a écrit dans le message de news:
%
Si tu ne veux que les fichiers soient dans excel, que ta volonté soit
faite !
;-)

dir c:*.xls* /s/n/o >c:Test.xls

à la limite, tu peux même actionner la commande à partir d'une macro :
'----------------------------------
Sub Afficher_les_Fichiers_Excel()
Shell "command.com /c dir c:*.xls /s/b >C:test.xls", vbHide
End Sub
'----------------------------------

Dis moi, quoi vouloir de plus ?
;-))




"garnote" a écrit dans le message de groupe de
discussion :

C'est OK pour le fichier texte mais là, j'en ai plus que voulu.
Je ne veux que les fichiers .xls avec nombre et taille.
J'aimerais bien que ça prenne une forme un peu semblable
à celle obtenue par mes macros.
Mais bon, ce n'est pas grave. Ce n'était qu'un exercice de VBA
pour explorer les répertoires.

Merci et A+

Moé

"garnote" a écrit dans le message de news:
%
Ave Denis,

Ma nullité DOS est sans bornes :-(
Voici ma question :
http://www.cijoint.fr/cjlink.php?file=cj200907/cijpMtdP82.xls

Serge

"MichDenis" a écrit dans le message de news:

Bonjour Garnote,

Pourquoi ne pas le faire en DOS

Tu ouvres une fenêtre DOS et tu tapes :
dir c: /S >c:Test.txt
ça va prendre quelques secondes et le tout est joué.
tout va être affiché dans ton fichier test.txt

Si tu tapes dir /? dans la fenêtre DOS, tu vas avoir tous les
commutateurs possibles.

"garnote" a écrit dans le message de groupe de
discussion :

Bonjour,

J'aimerais obtenir, sous une forme "agréable à consulter",
pour chaque répertoire et sous-répertoire de mes disques C et D,
le nombre et la taille totale de tous ses fichiers Excel.
Je ne suis pas très familier avec ce genre de chose.
Voici le début de mes timides efforts pour y arriver.
Sans devenir fou, peut-on automatiser tout ça ? :-)

Sub ListeRep()
rep = "D:" 'ou "D:Données ou ...
[A:B].ClearContents
Cells(1, 1) = rep
Cells(1, 1).Font.Bold = True
NomRep = Dir(rep, vbDirectory)
i = 2
Do While NomRep <> ""
If NomRep <> "." And NomRep <> ".." Then
If (GetAttr(rep & NomRep) And vbDirectory) = vbDirectory Then
Cells(i, 1) = NomRep
i = i + 1
End If
End If
NomRep = Dir
Loop
Columns("A:A").EntireColumn.AutoFit
End Sub

Sub nfxls()
Columns("A:B").ClearContents
rep = "D:Données"
nf = Dir("*.xls")
Do While nf <> ""
t = t + FileLen(rep & "" & nf)
n = n + 1
nf = Dir()
Loop
Cells(1, 1) = "Répertoire"
Cells(1, 2) = rep
Cells(2, 1) = "Nombre"
Cells(2, 2) = n
Cells(3, 1) = "Taille"
Cells(3, 2) = Format((t / 1000000), "0.00") & " Mo"
Columns("A:B").EntireColumn.AutoFit
End Sub

Serge










Avatar
MichDenis
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'---------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String
Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 0
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------
Avatar
MichDenis
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------
Avatar
J
Bonjour à tous
Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était
un peu difficile pour Serge ;-)
Rien que pour saisir ton code, Denis, je dois rajouter une barrette de
RAM ;-)
Bonne journée à vous 2.
Amicalement
J@@

MichDenis a écrit :
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx", "xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------






Avatar
garnote
> Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était un
peu difficile pour Serge ;-)


:-)))
À mon âge et avec le temps de chien qu'il fait à Québec, je dois
avouer que j'ai de gros problèmes de dos.
D'ailleurs, quand je sors de cellule, j'ai de la difficulté à m'adapter !

Serge



"J@@" a écrit dans le message de news:
ejQMq$
Bonjour à tous
Enfin quelque chose de simple! C'est vrai qu'en ligne commande, c'était un
peu difficile pour Serge ;-)
Rien que pour saisir ton code, Denis, je dois rajouter une barrette de
RAM ;-)
Bonne journée à vous 2.
Amicalement
J@@

MichDenis a écrit :
Et pour faire simple, il y a aussi ceci :

Différents bouts de code réunis dont un bout
de code publié sur le site de Frédéric Sigonneau.

'Variable dans le haut du module

Dim I As Integer
'-------------------------------------------------------
Sub TestGetFiles()
Dim Sh As Worksheet
Dim varItem As Variant
Dim strDirPath As String
Dim Répertoire_Par_Défaut As String

Répertoire_Par_Défaut = "C:UsersDM" 'à définir

If Dir(Répertoire_Par_Défaut) = "" Then
MsgBox "Chemin inexistant. Opération annulée."
Exit Sub
End If

I = 1
strDirPath = ChoixDossier(Répertoire_Par_Défaut)

Application.ScreenUpdating = False
Set Sh = Sheets.Add

If GetFiles(strDirPath, Sh, True) Then
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type",
"Attribut(s)")
With Sh.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End If
With Sh
With .Range("A1:H1")
.EntireColumn.AutoFit
End With
With .Range("A1:H" & .Range("A65536").End(xlUp).Row)
.Sort key1:=Sh.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
End With
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------
Function GetFiles(strPath As String, _
Sh As Worksheet, _
Optional blnRecursive As Boolean) As Boolean

Dim fsoSysObj As Object
Dim fdrFolder As Object
Dim fdrSubFolder As Object
Dim filFile As Object

If strPath = "C:UsersDMDocumentstest" Then Stop

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
GetFiles = False
GoTo GetFiles_End
End If
Err.Clear

For Each filFile In fdrFolder.Files
Select Case LCase(Split(filFile, ".")(1))
Case Is = "xls", "xlt", "xlb", "xlm", "xlsx", "xlxm", "xltx",
"xlsb"
I = I + 1
With filFile
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated,
_
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(I, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(I, UBound(ArrFSO) + 2).Value =
Attributs(File.Attributes)
End Select
Next filFile

If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, Sh, True
Next fdrSubFolder
End If

GetFiles = True
GetFiles_End:

Exit Function
End Function
'---------------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'---------------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Sélectionner le répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin
End Function
'---------------------------------------------







Avatar
Misange
garnote a écrit :
n'oublie pas de passer par Québec; je serai aux
premières loges !



j'y serai demain soir :-)
Misange migrateuse
http://www.excelabo.net : Participez à un travail collaboratif sur excel !
1 2