Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel recherche une macro excel pour lister les fichiers d'un dossier

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

3 réponses
Avatar
DV
recherche une macro permettant de lister dans un dossier excel la liste des
fichiers d'un dossier
Signaler un problème avec ce contenu

3 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
Avatar
j
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


Avatar
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


Avatar
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

'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