Tri d'un fichier texte par date

Tri d'un fichier texte par date - VB/VBA/VBS - Programmation

Marsh Posté le 06-06-2006 à 11:25:59    

Bonjour tout le monde.
 
Je cherche depuis un moment a lister le contenu d un repertoire et de ses sous repertoire pour en suite afficher les resultats du plus recent fichier au plus ancien... (c est dur a expliquer.. dites moi si c est pas clair).
 
Pour lister le contenu du repertoire c est pas facile pour moi qui ne connait rien en vb)... mais je demande surtout votre aide pour lister aussi le contenu dessous repertoire et classer tout ca par date...
 
Alors si vous avez des infos... je suis preneur! Merci a vous

Reply

Marsh Posté le 06-06-2006 à 11:25:59   

Reply

Marsh Posté le 06-06-2006 à 18:33:19    

changement tactique car c est plus simple...
 
Savez vous comment retourner les 10 fichiers les plus recents d un repertoire et de tous les sous repertoires qui le compose?

Reply

Marsh Posté le 06-06-2006 à 19:13:45    

A adapter


Option Explicit
 
'   Dans environnement VBA
'   Outils | Références cocher Microsoft Scripting Runtime
 
Private Sub TestListeFichiersDansDossier()
Const Dossier As String = "C:\Transfert\"
 
    Application.ScreenUpdating = False
    Cells.Clear
    Range("A3" ).Formula = "Nom:"
    Range("B3" ).Formula = "Taille:"
    Range("C3" ).Formula = "Type:"
    Range("D3" ).Formula = "Date Création:"
    Range("E3" ).Formula = "Date Dernier Accès:"
    Range("F3" ).Formula = "Date Dernière Modif:"
    Range("A3:F3" ).Font.Bold = True
    Range("A2" ).Select
     
    '  s'il n'y a pas de sous dossiers à visiter
    '  sinon ListeFichiersDansDossier Dossier, True
    ListeFichiersDansDossier Dossier, False
    Application.ScreenUpdating = True
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim r As Long
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
     
    r = Range("A65536" ).End(xlUp).Row + 1
    For Each Fichier In DossierSource.Files
        'Cells(r, 1).Formula = Fichier.Path
        Cells(r, 1).Formula = Fichier.Name
        Cells(r, 2).Formula = Fichier.Size
        Cells(r, 3).Formula = Fichier.Type
        Cells(r, 4).Formula = Fichier.DateCreated
        Cells(r, 5).Formula = Fichier.DateLastAccessed
        Cells(r, 6).Formula = Fichier.DateLastModified
        r = r + 1
    Next Fichier
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
    End If
    Columns("A:H" ).AutoFit
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub


Message édité par kiki29 le 01-12-2006 à 02:29:44
Reply

Marsh Posté le 06-06-2006 à 19:45:13    

je te remercie ....
 
je me penche la dessus et vous ferez un petit backup

Reply

Marsh Posté le 07-06-2006 à 09:27:31    

Voila j ai ca:
 

Code :
  1. Option Explicit
  2. Const Path = "F:\Mes Films"
  3. MsgBox ShowFolderList(Path),,"Liste des fichiers du répertoire """ & Path &vbCrLf&_
  4.       """ triés par date de modification (du + récent au + ancien)"
  5. Function ShowFolderList(strPath)
  6. Dim fso, Dossiers, fic, fichiers, strListe, f, r
  7. Dim Valeur, imax, z, Cible, liste
  8.     Set fso = CreateObject("Scripting.FileSystemObject" )
  9.     Set Dossiers = fso.GetFolder(Path)
  10.     Set fic = Dossiers.Files
  12.     imax = 0
  13.     For Each fichiers In fic
  14.         Set f = fso.GetFile(fichiers)
  15.         imax = imax + 1
  16.         ReDim Preserve Tableau(2, imax)
  17.         Tableau(1, imax) = f.Name
  18.         Tableau(2, imax) = f.DateCreated
  19.        
  20.         Valeur = 0
  21.         For imax = 1 To imax - 1
  22.             If CDate(Tableau(2, imax)) < CDate(Tableau(2, imax + 1)) Then
  23.                For z = 1 To 2
  24.                    Cible = Tableau(z, imax)
  25.                    Tableau(z, imax) = Tableau(z, imax + 1)
  26.                    Tableau(z, imax + 1) = Cible
  27.                Next
  28.                Valeur = 1
  29.             End If
  30.         Next
  31.     Next
  33. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  34. ' Affichage du résultat des fichiers triés par date de modification
  35. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  36.     liste = ""
  37.     For r = 1 To imax
  38.         liste = liste & vbCrLf & r & " " & Tableau(2, r) & " " & Tableau(1, r)
  39.     Next
  40.     liste = vbCrLf& "N° Date de modification Nom du fichier" &vbCrLf& liste
  41.     ShowFolderList = liste
  42.    
  43.     Set fso = Nothing
  44.     Set Dossiers = Nothing
  45.     Set fic = Nothing
  46.     Set f = Nothing
  48. End Function


 
 
Maintenant il faut que je l'adapte au balayage des sous-dossiers et ce sera parfait...


Message édité par dragonbools le 07-06-2006 à 09:28:42
Reply

Marsh Posté le 07-06-2006 à 12:31:05    

Une remarque en voyant le code que j'ai posté
Dans TestListeFichiersDansDossier()  remplacer ListeFichiersDansDossier Dossier, False par ListeFichiersDansDossier Dossier, True pour que le balayage prenne en compte les sous dossiers

Reply

Marsh Posté le 07-06-2006 à 19:48:11    


 
'Outils | Références Cocher Microsoft Scripting Runtime
'Nommer la zone A2..C65536 en ZoneTri
'Affecter un Bouton à TestListeFichiersDansDossier
'       en mettant auparavant TestListeFichiersDansDossier en Public et non Private
'Si recursion Dossier/Sous Dossiers
'       ListeFichiersDansDossier Dossier, True sinon ListeFichiersDansDossier Dossier, False
 
Option Explicit
 
Private Sub TestListeFichiersDansDossier()
Dim Dossier As String
    Application.ScreenUpdating = False
    Cells.Clear
    ' Dossier de test à adapter
    Dossier = "D:\Backup\Perso\"
 
    '  s'il n'y a pas de sous dossiers à visiter
    '  ListeFichiersDansDossier Dossier, False
    ListeFichiersDansDossier Dossier, True
    Tri
    MiseEnPage
    Application.ScreenUpdating = True
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim r As Long
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
     
    r = Range("A65536" ).End(xlUp).Row + 1
    For Each Fichier In DossierSource.Files
        Application.StatusBar = r - 1
        Cells(r, 1).Formula = Fichier.DateCreated
        Cells(r, 2).Formula = Fichier.DateLastModified
        Cells(r, 3).Formula = Fichier.Path
        'Cells(r, 3).Formula = Fichier.Name
        r = r + 1
    Next Fichier
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
    End If
         
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub MiseEnPage()
    Range("A1" ).Formula = "Date Création             "
    Range("B1" ).Formula = "Date Dernière Modification"
    Range("C1" ).Formula = "Nom"
    Range("A1:C1" ).Font.Bold = True
     
    Columns("A:C" ).AutoFit
    Columns("A:B" ).HorizontalAlignment = xlCenter
     
    Rows("1:1" ).Select
    With Selection
        .RowHeight = 30
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
    End With
     
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    Range("D1" ).Select
End Sub
 
Private Sub Tri()
    Range("ZoneTri" ).Sort Key1:=Range("B2" ), Order1:=xlDescending, _
                          Key2:=Range("A2" ), Order2:=xlAscending, _
                          Key3:=Range("C2" ), Order3:=xlAscending
End Sub


Message édité par kiki29 le 01-12-2006 à 02:35:50
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed