Modification code VBA existant

Bonjour le forum,

Après quelques recherches sur le site, j'ai trouvé le code qui pourrait faire mon bonheur ... enfin à quelques détails près ^^

Tout d'abord, je signale que je suis assez novice en VBA et que le code suivant appartient à "BOUBEN" (que je remercie en passant )

Alors pour simplifier la lecture du code, celui-ci permet de lister le contenu d'un dossier.

Parfait jusque là : il me faudrait de l'aide pour 2 petites modifications :

  • est-il possible de supprimer l'extension du fichier listé (.pdf, .xls etc ...) dans la colonne A.
  • est-il possible de faire en sorte que les fichiers listés dans la feuille excel ne se vide pas. Je m'explique le dossier que je dois lister chaque jour est dynamique, de ce fait des éléments peuvent être rajoutés ou supprimés et moi je souhaite qu'une fois insérer dans la feuille excel, il ne bouge plus et que le nouveau listing se rajoute à l'ancien et que le tout soit ordonné par date, du plus récent au plus ancien.

Je vous joints le fichier en question.

Merci d'avance pour votre aide.

12listefichiers.xlsm (23.66 Ko)

Bonjour Samsam, bonjour le forum,

Super code de BOUBEN !...

Je pense qu'il y a inversion entre les dates de création et de dernière modification... Rajoute Date de Récup en G1 car on stockera dans cette colonne la date du lancement de la macro.

Le code modifié :

Option Explicit
Private moFSO As FileSystemObject

Public Sub Lister()
Dim sRepPrinc As String
Dim iDerLig As Integer

Set moFSO = New FileSystemObject
sRepPrinc = "C:\TEST"
'RAZ
iDerLig = Range("A" & Rows.Count).End(xlUp).Row
'If iDerLig >= 2 Then
'    Rows("2:" & iDerLig).Delete
'End If
'liste récursive
ListeFichiers sRepPrinc
'tri par nom
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range _
    ("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With ActiveSheet.AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'largeur auto
Range("A:F").EntireColumn.AutoFit
MsgBox "Terminé !", vbExclamation
Set moFSO = Nothing
End Sub

Private Sub ListeFichiers(psRep As String)
Dim iLig As Integer
Dim oFic As File
Dim oRep As Folder
Dim NP As String
Dim POS As Integer
'fichiers
For Each oFic In moFSO.GetFolder(psRep).Files
    iLig = Range("A" & Rows.Count).End(xlUp).Row + 1
    NP = UBound(Split(oFic.Name, "."))
    POS = InStr(1, oFic.Name, Split(oFic.Name, ".")(NP), vbTextCompare) - 2
    Range("A" & iLig).Value = Left(oFic.Name, POS)
    Range("B" & iLig).Value = psRep
    Range("C" & iLig).Value = oFic.DateCreated
    Range("D" & iLig).Value = oFic.DateLastModified
    Range("E" & iLig).Value = oFic.Size
    Range("F" & iLig).Value = oFic.Type
    Range("G" & iLig).Value = DateSerial(Year(Date), Month(Date), Day(Date))
Next oFic
'sous-répertoires
For Each oRep In moFSO.GetFolder(psRep).SubFolders
    ListeFichiers oRep.Path
Next oRep
End Sub

Salut,

Je pense que le fichier ci-joint devrait répondre à ton attente.

Amicalement.

Bonsoir ThauThème,

Bonsoir Yvouille,

Tout d'abord un grand merci pour vos retours respectifs. Super rapide comme toujours sur le forum !!

Je jette un coup d’œil sur vos codes dans la journée. J'ai testé le fichier d'Yvouille et il semble faire le taf !!

Je dois tester un peu plus dans le détails ^^

Je testerai également le code de ThauThème mais je suis assez serein aussi sur le résultat.

Une fois cela fait, je reviendrai pour vous dire et fermer la discussion ^^

Bonne journée.

Salut,

Une fois cela fait, je reviendrai pour vous dire et fermer la discussion ^^

Tu penses revenir vers quelle heure ?

Salut !

Oui pardon pardon .... en effet, j'ai un peu zappé de revenir fermé la discussion.

C'est Ok pour les codes, testés et validés ^^

Encore un grand merci pour les retours ... super boulot de votre part

Je peux clôturer la discussion.

Bonne soirée à tous.

Rechercher des sujets similaires à "modification code vba existant"