jette un oeil sur http://jacxl.free.fr/cours_xl/explore.html
"DV" a écrit dans le message de news:
recherche une macro permettant de lister dans un dossier excel la liste des
fichiers d'un dossier
JB
Bonjour,
Sub ListeFichiers2() repertoire = ThisWorkbook.Path ' adapter i = 2 nf = Dir(repertoire & "*.xls") ' premier fichier Do While nf <> "" Cells(i, 1) = nf nf = Dir ' suivant i = i + 1 Loop End Sub
JB http://boisgontierjacques.free.fr/
On 21 fév, 18:44, DV wrote:
recherche une macro permettant de lister dans un dossier excel la liste de s fichiers d'un dossier
Bonjour,
Sub ListeFichiers2()
repertoire = ThisWorkbook.Path ' adapter
i = 2
nf = Dir(repertoire & "*.xls") ' premier fichier
Do While nf <> ""
Cells(i, 1) = nf
nf = Dir ' suivant
i = i + 1
Loop
End Sub
JB
http://boisgontierjacques.free.fr/
On 21 fév, 18:44, DV <D...@discussions.microsoft.com> wrote:
recherche une macro permettant de lister dans un dossier excel la liste de s
fichiers d'un dossier
Sub ListeFichiers2() repertoire = ThisWorkbook.Path ' adapter i = 2 nf = Dir(repertoire & "*.xls") ' premier fichier Do While nf <> "" Cells(i, 1) = nf nf = Dir ' suivant i = i + 1 Loop End Sub
JB http://boisgontierjacques.free.fr/
On 21 fév, 18:44, DV wrote:
recherche une macro permettant de lister dans un dossier excel la liste de s fichiers d'un dossier
BenZac
Bonjour DV,
J'en avait rédigé une.
Mise en place et à partir d'un nouveau classeur : - Cellule B1 : mettre le chemin du répertoire à analyser (c:rep ou serveurpartagerep) - Lancer la macro ScanFolder
Résultat : - Cellule D1 : la taille du répertoire analyser - Cellule F1 : le nombre de fichiers trouvés - A partir de la ligne 3 : colonne A : le nom du répertoire ou fichier colonne B : le nombre de fichier pour le sous-répertoire colonne C : la taille en Ko du sous-répertoire ou fichier colonne D : la date de création du sous-répertoire ou fichier colonne E : la date du dernier accès du sous-répertoire ou fichier colonne F : la date de modification du sous-répertoire ou fichier - Pour faciliter la lecture, chaque sous-répertoire à une couleur différente du sous-répertoire précédent.
Module : Dim folder As String Dim ligne As Integer Dim col As Integer Dim coul0 As Integer Dim coul1 As Integer Dim coul2 As Integer Dim nb_file As Integer Dim nb_folder As Integer Dim size As Integer Dim dateconv Sub ScanFolder() On Error Resume Next 'On efface les résultats précédents ligne = 3 Cells(1, 6).Value = 0 Do Until IsEmpty(Cells(ligne, 1)) For col = 1 To 6 With Cells(ligne, col) .Value = "" .Interior.ColorIndex = 0 .Borders(xlEdgeLeft).LineStyle = xlLineStyleNone .Borders(xlEdgeTop).LineStyle = xlLineStyleNone .Borders(xlEdgeBottom).LineStyle = xlLineStyleNone .Borders(xlEdgeRight).LineStyle = xlLineStyleNone .Borders(xlInsideVertical).LineStyle = xlLineStyleNone .Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone End With Next ligne = ligne + 1 Loop
'Affichage de la fin du Traitement mess = "Traitement terminé pour " & UCase(Cells(1, 2).Value) & vbCrLf & vbCrLf mess = mess & "Sous-Dossiers.... " & nb_folder & vbCrLf mess = mess & "Fichiers............... " & nb_file & vbCrLf fin = MsgBox(mess, vbInformation, "Analyse de répertoire") End Sub Sub ScanSubFolder() On Error Resume Next
'Pour chaque répertoire For Each objFolder In colSubfolders nb_folder = nb_folder + 1 folder = "" folder = objFolder.Name If folder <> "" Then couleur 'change la couleur des cellule NbFile 'compte le nombre de fichiers ligne = ligne + 1 ScanSubFolder 'relance recursive de la routine End If Next End Sub Sub couleur() On Error Resume Next
TabLevel = Split(folder, "", -1, vbTextCompare) If TabLevel(1) = "" Then level = 0 Else level = UBound(TabLevel) ' + 1 End If Tab0 = Split(Cells(ligne - 1, 1).Value, "", -1, vbTextCompare) Tab1 = Split(Cells(ligne, 1).Value, "", -1, vbTextCompare)
If Cells(1, 6).Value <> 0 Then If UCase(Tab0(level)) <> UCase(Tab1(level)) Then coul2 = coul0 coul0 = coul1 coul1 = coul2 End If End If
For i = 1 To 6 Cells(ligne, i).Interior.ColorIndex = coul0 Next End Sub Sub NbFile() On Error Resume Next Set fs = Application.FileSearch Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.getfolder(folder) Cells(ligne, 1).Value = rep.Path Cells(ligne, 4).Value = rep.datecreated Cells(ligne, 5).Value = rep.dateLastAccessed Cells(ligne, 6).Value = rep.dateLastModified If ligne = 3 Then Cells(1, 4).Value = Round(rep.size / 1024, 0) End If Set rep = nothihng
With fs .LookIn = folder .Filename = "*.*" .SearchSubFolders = False If .Execute > 0 Then Cells(1, 6).Value = Cells(1, 6).Value + .FoundFiles.Count Cells(ligne, 2).Value = .FoundFiles.Count rLigne = ligne For i = 1 To .FoundFiles.Count ligne = ligne + 1 Set f = fso.getfile(.FoundFiles(i)) Cells(rLigne, 3).Value = Round(Cells(rLigne, 3).Value + (f.size / 1024), 0) Cells(ligne, 1).Value = f.Path Cells(ligne, 3).Value = f.size / 1024 Cells(ligne, 4).Value = f.datecreated Cells(ligne, 5).Value = f.dateLastAccessed Cells(ligne, 6).Value = f.dateLastModified Set f = Nothing size = size + (f.size / 1024) nb_file = nb_file + 1 couleur Next i Else Cells(ligne, 2).Value = 0 Cells(ligne, 3).Value = 0 End If End With Cells(ligne, 2).NumberFormat = "### ### ###,##0" Cells(ligne, 3).NumberFormat = "### ### ###,##0" Set fs = Nothing End Sub
BenZac
Bonjour DV,
J'en avait rédigé une.
Mise en place et à partir d'un nouveau classeur :
- Cellule B1 : mettre le chemin du répertoire à analyser (c:rep ou
serveurpartagerep)
- Lancer la macro ScanFolder
Résultat :
- Cellule D1 : la taille du répertoire analyser
- Cellule F1 : le nombre de fichiers trouvés
- A partir de la ligne 3 :
colonne A : le nom du répertoire ou fichier
colonne B : le nombre de fichier pour le sous-répertoire
colonne C : la taille en Ko du sous-répertoire ou fichier
colonne D : la date de création du sous-répertoire ou
fichier
colonne E : la date du dernier accès du sous-répertoire
ou fichier
colonne F : la date de modification du sous-répertoire ou
fichier
- Pour faciliter la lecture, chaque sous-répertoire à une couleur
différente du sous-répertoire précédent.
Module :
Dim folder As String
Dim ligne As Integer
Dim col As Integer
Dim coul0 As Integer
Dim coul1 As Integer
Dim coul2 As Integer
Dim nb_file As Integer
Dim nb_folder As Integer
Dim size As Integer
Dim dateconv
Sub ScanFolder()
On Error Resume Next
'On efface les résultats précédents
ligne = 3
Cells(1, 6).Value = 0
Do Until IsEmpty(Cells(ligne, 1))
For col = 1 To 6
With Cells(ligne, col)
.Value = ""
.Interior.ColorIndex = 0
.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
.Borders(xlEdgeRight).LineStyle = xlLineStyleNone
.Borders(xlInsideVertical).LineStyle = xlLineStyleNone
.Borders(xlInsideHorizontal).LineStyle =
xlLineStyleNone
End With
Next
ligne = ligne + 1
Loop
'Affichage de la fin du Traitement
mess = "Traitement terminé pour " & UCase(Cells(1, 2).Value) &
vbCrLf & vbCrLf
mess = mess & "Sous-Dossiers.... " & nb_folder & vbCrLf
mess = mess & "Fichiers............... " & nb_file & vbCrLf
fin = MsgBox(mess, vbInformation, "Analyse de répertoire")
End Sub
Sub ScanSubFolder()
On Error Resume Next
'Pour chaque répertoire
For Each objFolder In colSubfolders
nb_folder = nb_folder + 1
folder = ""
folder = objFolder.Name
If folder <> "" Then
couleur 'change la couleur des
cellule
NbFile 'compte le nombre de
fichiers
ligne = ligne + 1
ScanSubFolder 'relance recursive de
la routine
End If
Next
End Sub
Sub couleur()
On Error Resume Next
TabLevel = Split(folder, "", -1, vbTextCompare)
If TabLevel(1) = "" Then
level = 0
Else
level = UBound(TabLevel) ' + 1
End If
Tab0 = Split(Cells(ligne - 1, 1).Value, "", -1, vbTextCompare)
Tab1 = Split(Cells(ligne, 1).Value, "", -1, vbTextCompare)
If Cells(1, 6).Value <> 0 Then
If UCase(Tab0(level)) <> UCase(Tab1(level)) Then
coul2 = coul0
coul0 = coul1
coul1 = coul2
End If
End If
For i = 1 To 6
Cells(ligne, i).Interior.ColorIndex = coul0
Next
End Sub
Sub NbFile()
On Error Resume Next
Set fs = Application.FileSearch
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.getfolder(folder)
Cells(ligne, 1).Value = rep.Path
Cells(ligne, 4).Value = rep.datecreated
Cells(ligne, 5).Value = rep.dateLastAccessed
Cells(ligne, 6).Value = rep.dateLastModified
If ligne = 3 Then
Cells(1, 4).Value = Round(rep.size / 1024, 0)
End If
Set rep = nothihng
With fs
.LookIn = folder
.Filename = "*.*"
.SearchSubFolders = False
If .Execute > 0 Then
Cells(1, 6).Value = Cells(1, 6).Value + .FoundFiles.Count
Cells(ligne, 2).Value = .FoundFiles.Count
rLigne = ligne
For i = 1 To .FoundFiles.Count
ligne = ligne + 1
Set f = fso.getfile(.FoundFiles(i))
Cells(rLigne, 3).Value = Round(Cells(rLigne, 3).Value
+ (f.size / 1024), 0)
Cells(ligne, 1).Value = f.Path
Cells(ligne, 3).Value = f.size / 1024
Cells(ligne, 4).Value = f.datecreated
Cells(ligne, 5).Value = f.dateLastAccessed
Cells(ligne, 6).Value = f.dateLastModified
Set f = Nothing
size = size + (f.size / 1024)
nb_file = nb_file + 1
couleur
Next i
Else
Cells(ligne, 2).Value = 0
Cells(ligne, 3).Value = 0
End If
End With
Cells(ligne, 2).NumberFormat = "### ### ###,##0"
Cells(ligne, 3).NumberFormat = "### ### ###,##0"
Set fs = Nothing
End Sub
Mise en place et à partir d'un nouveau classeur : - Cellule B1 : mettre le chemin du répertoire à analyser (c:rep ou serveurpartagerep) - Lancer la macro ScanFolder
Résultat : - Cellule D1 : la taille du répertoire analyser - Cellule F1 : le nombre de fichiers trouvés - A partir de la ligne 3 : colonne A : le nom du répertoire ou fichier colonne B : le nombre de fichier pour le sous-répertoire colonne C : la taille en Ko du sous-répertoire ou fichier colonne D : la date de création du sous-répertoire ou fichier colonne E : la date du dernier accès du sous-répertoire ou fichier colonne F : la date de modification du sous-répertoire ou fichier - Pour faciliter la lecture, chaque sous-répertoire à une couleur différente du sous-répertoire précédent.
Module : Dim folder As String Dim ligne As Integer Dim col As Integer Dim coul0 As Integer Dim coul1 As Integer Dim coul2 As Integer Dim nb_file As Integer Dim nb_folder As Integer Dim size As Integer Dim dateconv Sub ScanFolder() On Error Resume Next 'On efface les résultats précédents ligne = 3 Cells(1, 6).Value = 0 Do Until IsEmpty(Cells(ligne, 1)) For col = 1 To 6 With Cells(ligne, col) .Value = "" .Interior.ColorIndex = 0 .Borders(xlEdgeLeft).LineStyle = xlLineStyleNone .Borders(xlEdgeTop).LineStyle = xlLineStyleNone .Borders(xlEdgeBottom).LineStyle = xlLineStyleNone .Borders(xlEdgeRight).LineStyle = xlLineStyleNone .Borders(xlInsideVertical).LineStyle = xlLineStyleNone .Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone End With Next ligne = ligne + 1 Loop
'Affichage de la fin du Traitement mess = "Traitement terminé pour " & UCase(Cells(1, 2).Value) & vbCrLf & vbCrLf mess = mess & "Sous-Dossiers.... " & nb_folder & vbCrLf mess = mess & "Fichiers............... " & nb_file & vbCrLf fin = MsgBox(mess, vbInformation, "Analyse de répertoire") End Sub Sub ScanSubFolder() On Error Resume Next
'Pour chaque répertoire For Each objFolder In colSubfolders nb_folder = nb_folder + 1 folder = "" folder = objFolder.Name If folder <> "" Then couleur 'change la couleur des cellule NbFile 'compte le nombre de fichiers ligne = ligne + 1 ScanSubFolder 'relance recursive de la routine End If Next End Sub Sub couleur() On Error Resume Next
TabLevel = Split(folder, "", -1, vbTextCompare) If TabLevel(1) = "" Then level = 0 Else level = UBound(TabLevel) ' + 1 End If Tab0 = Split(Cells(ligne - 1, 1).Value, "", -1, vbTextCompare) Tab1 = Split(Cells(ligne, 1).Value, "", -1, vbTextCompare)
If Cells(1, 6).Value <> 0 Then If UCase(Tab0(level)) <> UCase(Tab1(level)) Then coul2 = coul0 coul0 = coul1 coul1 = coul2 End If End If
For i = 1 To 6 Cells(ligne, i).Interior.ColorIndex = coul0 Next End Sub Sub NbFile() On Error Resume Next Set fs = Application.FileSearch Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.getfolder(folder) Cells(ligne, 1).Value = rep.Path Cells(ligne, 4).Value = rep.datecreated Cells(ligne, 5).Value = rep.dateLastAccessed Cells(ligne, 6).Value = rep.dateLastModified If ligne = 3 Then Cells(1, 4).Value = Round(rep.size / 1024, 0) End If Set rep = nothihng
With fs .LookIn = folder .Filename = "*.*" .SearchSubFolders = False If .Execute > 0 Then Cells(1, 6).Value = Cells(1, 6).Value + .FoundFiles.Count Cells(ligne, 2).Value = .FoundFiles.Count rLigne = ligne For i = 1 To .FoundFiles.Count ligne = ligne + 1 Set f = fso.getfile(.FoundFiles(i)) Cells(rLigne, 3).Value = Round(Cells(rLigne, 3).Value + (f.size / 1024), 0) Cells(ligne, 1).Value = f.Path Cells(ligne, 3).Value = f.size / 1024 Cells(ligne, 4).Value = f.datecreated Cells(ligne, 5).Value = f.dateLastAccessed Cells(ligne, 6).Value = f.dateLastModified Set f = Nothing size = size + (f.size / 1024) nb_file = nb_file + 1 couleur Next i Else Cells(ligne, 2).Value = 0 Cells(ligne, 3).Value = 0 End If End With Cells(ligne, 2).NumberFormat = "### ### ###,##0" Cells(ligne, 3).NumberFormat = "### ### ###,##0" Set fs = Nothing End Sub