Scan de répertoire
bonjour
journalliérement je sauvegarde des email dans un répertoire, au format MHT
je me demande s'il y a un moyen de créer un fichier excel qui....quand je l'ouvre scan le repertoire et me met dans un colone (exemple A) tous les noms des fichier 1 à 1
merci pour l'aide
Bonsoir,
D'abord La procédure nécessite d'activer la référence "Microsoft Scripting RunTime".
Dans l'éditeur de macros (Alt+F11):
Menu Outils
Références
Cliquez sur le bouton OK pour valider.
copier le code dans un module et l'affecter à un bouton
change le nécessaire chemin, extension
Option Explicit
Sub Lister_Fichiers()
Dim Fichier As String, Chemin As String
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
'
Dim Fso As Scripting.FileSystemObject
Dim FileItem As Scripting.File
Dim Tableau()
Dim Plage As Range
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
'---liste les fichiers du répertoire ---
Chemin = "D:\POI" 'à changer
Fichier = Dir(Chemin & "\*.MHT") ' à changer selon le besoin
'Boucle sur les fichiers
Do
m = m + 1
ReDim Preserve Tableau(1 To 2, 1 To m)
Tableau(1, m) = Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
'Récupère la date de création
Tableau(2, m) = Left(FileItem.DateCreated, 10)
'Pour récupérer la date de dernière modification
'Tableau(2, m) = Left(FileItem.DateLastModified, 10)
'Pour récupérer la taille du fichier
'Tableau(2, m) = Left(FileItem.Size, 10)
Fichier = Dir
Loop Until Fichier = ""
'---Trie les fichiers par ordre décroissant de création ---
Do
Valeur = 0
For i = 1 To m - 1
If CDate(Tableau(2, i)) < CDate(Tableau(2, i + 1)) Then
For z = 1 To 2
Cible = Tableau(z, i)
Tableau(z, i) = Tableau(z, i + 1)
Tableau(z, i + 1) = Cible
Next z
Valeur = 1
End If
Next i
Loop While Valeur = 1
'--- Transfère les données dans la feuille de calcul ---
Set Plage = Worksheets("Feuil1").Range("A1")
Set Plage = Plage.Resize(UBound(Tableau(), 2), UBound(Tableau()))
Plage = Application.Transpose(Tableau())
End Sub
Bonjour
yesssssssssssssss
ça fonctionne
merci