recherche une macro excel pour lister les fichiers d'un dossier

Le
DV
recherche une macro permettant de lister dans un dossier excel la liste des
fichiers d'un dossier
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
j
Le #5242351
jette un oeil sur
http://jacxl.free.fr/cours_xl/explore.html



"DV"
recherche une macro permettant de lister dans un dossier excel la liste
des

fichiers d'un dossier


JB
Le #5242341
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
recherche une macro permettant de lister dans un dossier excel la liste de s
fichiers d'un dossier


BenZac
Le #5241391
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

'Initialisations des Variables
folder = Cells(1, 2).Value
ligne = 3
coul0 = 35
coul1 = 36
coul2 = 35
nb_file = 0
size = 0

'TRAITEMENT
couleur
NbFile
ScanSubFolder

'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

'Declaration des Objets WMI
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\" & strComputer & "root
cimv2")
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & folder & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")

'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
Publicité
Poster une réponse
Anonyme