Microsoft 365 lister des fichiers

Usine à gaz

XLDnaute Barbatruc
Bonsoir à toutes et à tous :)

Je bute (comme tjr) sur un code que je voudrais modifier.
Ce code a été donné sur notre Forum et je n'avais pas pris le lien du fil (Grrrrr à moi :mad:), du coup je remercie "le soldat inconnu" de moi :)
Il fonctionne très bien et donne la liste des fichiers avec le chemin et les liens.

J'ai deux besoins :
1 - Qu'il me donne uniquement les noms des fichiers avec leurs liens (sans le chemin),
2 - Dans mon fichier, je vais mettre des commentaires à droite des noms des fichiers
--- Serait-il possible à l'ajout de fichiers dans le dossier, qu'à la mise à jour le code ajoute les nouveaux fichiers après ceux existants ?
Cela m'éviterait de perdre mes commentaires et/ou des décalages ou mélanges.

Vu mon niveau "d'ExpertDeRien", j'ai tenté de voir mais j'ai rien vu lol :D
Pourriez-vous m'aider ?
Je joins le fichier et voici ses codes :
VB:
Option Explicit
Option Compare Text

'---------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'par la "méthode FileSystemObject"
'
'- NomRépertoire: chaine du nom du répertoire concerné
'                 (avec ou sans '\' final)
'
'- NoRecycle: True (valeur par défaut) pour ne pas avoir les
'             fichiers de la poubelle dans la liste résultat
'             si NomRépertoire est une lettre de lecteur (drive)
'
'- Extension: "Pattern" / modèle de l'extension des fichiers à
'             sélectionner ("txt", "xls*" ou "" pour tous)
'
'- DateCréation: True retourne la date de création en 2ème
'                     dimension
'
'- DateModification: True retourne la date de Modification en
'                    2ème dimension
'
'- Taille: True retourne la taille en 2ème dimension
'
'- Return: Table à 1 dimension des noms complets des fichiers
'          Table à 2 dimensions si DateCréation = True,
'                            et/ou DateModification = True,
'                            et/ou Taille = True.
'          ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, _
                               Optional SousRépertoires As Boolean = True, _
                               Optional NoRecycle As Boolean = True, _
                               Optional Extension As String = "", _
                               Optional DateCréation As Boolean = False, _
                               Optional DateModification As Boolean = False, _
                               Optional Taille As Boolean = False) As Variant
                            
    'Tableau résultat static pour être indépendant des appels récursifs
    Static TabFichiers() As String
    Static NbFichiers As Long
    Static Dimension2 As Integer
    Static Dimension2DateCréation As Integer
    Static Dimension2DateModification As Integer
    Static Dimension2Taille As Integer
  
    'Variable du FileSystemObject commune à toutes les instances de la fonction
    Static oFSO As Object
  
    'Variable spécifiques à une instance de la fonction
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object
    Dim InitialCall As Boolean
    Dim TakeIt As Boolean
    Dim NomObjetEnErreur As String
  
    'Appel recursif de cette fonction (par elle-même ci-dessous)
    If TypeOf NomRépertoire Is Object  Then
        InitialCall = False
      
        'Valorise l'objet Folder
        Set oDir = NomRépertoire
  
    'Appel initial
    Else
         InitialCall = True
      
        'Table résultat
        Erase TabFichiers
        NbFichiers = 0
        Dimension2 = IIf(DateCréation, 1, 0) + IIf(DateModification, 1, 0) + IIf(Taille, 1, 0)
        If Dimension2 > 0 Then
            Dimension2 = 1 + Dimension2
            Dimension2DateCréation = 1 + IIf(DateCréation, 1, 0)
            Dimension2DateModification = Dimension2DateCréation + IIf(DateModification, 1, 0)
            Dimension2Taille = Dimension2DateModification + IIf(Taille, 1, 0)
        End If
      
        'File System Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
      
        'Complémente éventuellement le nom du répertoire avec '\'
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
      
        'Valorise l'objet Folder
        Set oDir = oFSO.GetFolder(NomRépertoire)
    End If
  
    'Si option NoRecycle et répertoire poubelle on ne traite pas
    If NoRecycle And Len(oDir.Name) = 12 Then
        If UCase(oDir.Name) = "$RECYCLE.BIN" Then Exit Function
    End If
  
    'Si le répertoire est "System Volume Information" on ne traite pas
    If oDir.Name = "System Volume Information" Then Exit Function
  
    'Vérifie si le répertoire contient des fichiers avec l'extension
    If Len(Extension) = 0 Then
        TakeIt = True
    Else
         'Il faut couvrir la fonction Dir() par un On Error pour intercepter ses erreurs:
        'Erreur #52:
        '> Accès refusé
        '> Un ou plusieurs caractères du nom du répertoire sont codés en Unicode
        'Erreurs #53:
        '> La longueur du chemin est > longueur maxi
        'Erreurs qui sinon vont se manifester ultérieurement dans la boucle "For Each oSubDir In oDir.subfolders".
        On Error Resume Next
        TakeIt = Len(Dir(oDir.Path & "\*." & Extension)) > 0
        If Err.Number <> 0 Then TakeIt = True
        On Error GoTo 0
    End If

    'On n'examine les fichiers du répertoire que s'il contient des fichiers avec l'extension
    If TakeIt Then
        On Error Resume Next
        For Each oFile In oDir.Files
            If Err.Number = 0 Then
                'Test si correspondance de l'extension
                If Len(Extension) = 0 Then
                    TakeIt = True
                Else
                    If oFSO.GetExtensionName(oFile.Name) Like Extension Then TakeIt = True Else TakeIt = False
                End If
              
                'Stocke le nom complet du fichier en table
                If TakeIt Then
                    NbFichiers = NbFichiers + 1
                    If Dimension2 = 0 Then
                        ReDim Preserve TabFichiers(1 To NbFichiers)
                        TabFichiers(NbFichiers) = oFile.Path
                    Else
                        ReDim Preserve TabFichiers(1 To Dimension2, 1 To NbFichiers)
                        TabFichiers(1, NbFichiers) = oFile.Path
                        'Récupère la date de création
                        If DateCréation Then TabFichiers(Dimension2DateCréation, NbFichiers) = oFile.DateCreated
                        'Récupére la date de dernière modification
                        If DateModification Then TabFichiers(Dimension2DateModification, NbFichiers) = oFile.DateLastModified
                        'Récupére la taille du fichier
                        If Taille Then TabFichiers(Dimension2Taille, NbFichiers) = Left(oFile.Size, 10)
                    End If
                End If
          
            'Fichier en erreur
            Else
                NomObjetEnErreur = "Fichier <"
                If oFile Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oFile.Name & ">"
                GoSub TraiteErreur
            End If
        Next oFile
        On Error GoTo 0
    End If
  
    If SousRépertoires Then
        'Parcours des sous-répertoires du répertoire en cours
        On Error Resume Next
        For Each oSubDir In oDir.subfolders
            If Err.Number = 0 Then
                'Appels recursifs identifiés par le type Object de l'argument OsubDir
                 Call FichiersRépertoireFSO(oSubDir, SousRépertoires, NoRecycle, Extension, DateCréation, DateModification, Taille)
          
            'Répertoire en erreur
            Else
                NomObjetEnErreur = "Répertoire <"
                If oSubDir Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oSubDir.Path & ">"
                GoSub TraiteErreur
            End If
        Next oSubDir
        On Error GoTo 0
    End If
  
    'Return value
    If InitialCall Then
        If NbFichiers > 0 Then
            If Dimension2 = 0 Then
                FichiersRépertoireFSO = TabFichiers
            Else
                FichiersRépertoireFSO = Transpose(TabFichiers)
            End If
        Else
            FichiersRépertoireFSO = False
        End If
    End If
    Exit Function
  
TraiteErreur:
    Select Case Err.Number
        'Error #70 Authorisation refusée
        Case 70
            MsgBox "Accès refusé pour le fichier <" & NomObjetEnErreur & ">."
          
        'Error #76 Path not found - Cas des noms de répertoires ou fichiers dont le chemin complet > Maximum (247, 259)
        Case 76
            MsgBox "Nom trop long pour le fichier <" & NomObjetEnErreur & ">."
      
        'Autre erreur à identifier ?
        Case Else
            MsgBox "FichiersRépertoireFSO erreur #" & Err.Number & vbCrLf & "Sur " & NomObjetEnErreur & ""
    End Select
  
    NomObjetEnErreur = ""
    Err.Clear
    Return
End Function

'---------
'Transpose
'---------
Private Function Transpose(t As Variant) As Variant
    Dim tt() As Variant
    Dim i As Long
    Dim j As Long
  
    ReDim tt(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
  
    For i = LBound(t, 2) To UBound(t, 2)
        For j = LBound(t, 1) To UBound(t, 1)
            tt(i, j) = t(j, i)
        Next j
    Next i
  
    Transpose = tt
End Function
Code:
Option Explicit
Sub ListerLesFichiers()
    Dim TabFichiers As Variant
    Dim Répertoire As String
    Dim i As Long
  
    Répertoire = [a1].Value
  
    TabFichiers = FichiersRépertoireFSO(Répertoire)
    'ActiveSheet.Columns(1).ClearContents
                                      
    If VarType(TabFichiers) = vbBoolean Then
        MsgBox "Aucun fichier en répertoire <" & Répertoire & ">"
    Else
        If UBound(TabFichiers) <= 65535 Then
            ActiveSheet.[A2].Resize(UBound(TabFichiers), 2).Value = Application.Transpose(TabFichiers)
        Else
            ActiveSheet.[A2].Value = "Utiliser un Transpose codé."
        End If
    End If
  
    For i = 1 To UBound(TabFichiers, 1)
        'Ajoute l'Hyperlien
        ActiveSheet.Hyperlinks.Add Anchor:=[A2].Offset(i - 1), _
                                   Address:=[A2].Offset(i - 1).Value
    Next i
  
    Columns("B:B").Delete Shift:=xlToLeft
    '[a1] = [a1].Value
End Sub
Un grand merci pour votre aide
:)
 

Pièces jointes

  • ListerLesFichiers.xlsm
    34.1 KB · Affichages: 11
Dernière édition:
Solution
c'est le cas.
Je veux bien lol
:)
Tu vois Lionel ton problème c'est que tu télécharges n'importe quoi, même les usines à gaz :oops:

Télécharge les fichiers joints dans le même dossier (le bureau) et ouvre le fichier .xlsm.

La macro affectée au bouton :
VB:
Sub MAJ()
Dim chemin$, fichier$, lig&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
With ActiveSheet.Columns(1) 'feuille et colonne à adapter
    lig = .Cells(Rows.Count).End(xlUp).Row + 1
    While fichier <> ""
        If fichier <> ThisWorkbook.Name And IsError(Application.Match(fichier, .Cells, 0)) Then
            .Parent.Hyperlinks.Add .Cells(lig), chemin & fichier...

job75

XLDnaute Barbatruc
Bonjour Lionel, le forum,

S'il y a beaucoup de fichiers à lister (plusieurs milliers) on utilisera le Dictionary pour gagner du temps :
VB:
Sub MAJ()
Dim chemin$, fichier$, d As Object, lig&, tablo, i&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
With ActiveSheet.Columns(1) 'feuille et colonne à adapter
    lig = .Cells(Rows.Count).End(xlUp).Row + 1
    tablo = .Cells.Resize(lig - 1, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo)
        d(tablo(i, 1)) = ""
    Next
    While fichier <> ""
        If fichier <> ThisWorkbook.Name And Not d.exists(fichier) Then
            .Parent.Hyperlinks.Add .Cells(lig), chemin & fichier, TextToDisplay:=fichier
            lig = lig + 1
        End If
        fichier = Dir 'fichier suivant
    Wend
    .Resize(, 2).AutoFit 'ajustement largeurs
End With
End Sub
Testée avec 10 000 fichiers la macro s'exécute chez moi en 2,8 secondes.

A+
 

Pièces jointes

  • Liste fichiers(1).xlsm
    19.1 KB · Affichages: 7
  • Bonjour.xlsx
    8.6 KB · Affichages: 4
  • Forum.xlsx
    8.6 KB · Affichages: 4

job75

XLDnaute Barbatruc
Et pour aller encore plus vite on utilisera la fonction LIEN_HYPERTEXTE entrée dans un tableau VBA :
VB:
Sub MAJ()
Dim chemin$, fichier$, d As Object, lig&, tablo, i&, liste$(), n&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With ActiveSheet.Columns(1) 'feuille et colonne à adapter
    lig = .Cells(Rows.Count).End(xlUp).Row + 1
    tablo = .Cells.Resize(lig - 1, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo)
        d(tablo(i, 1)) = ""
    Next
    While fichier <> ""
        If fichier <> ThisWorkbook.Name And Not d.exists(fichier) Then
            ReDim Preserve liste(n) 'base 0
            liste(n) = "=HYPERLINK(""" & chemin & fichier & """,""" & fichier & """)"
            n = n + 1
        End If
        fichier = Dir 'fichier suivant
    Wend
    '---restitution---
    If n Then .Cells(lig).Resize(n) = Application.Transpose(liste) 'Transpose est limitée à 65536 lignes
    .Resize(, 2).AutoFit 'ajustement largeurs
End With
End Sub
Avec 10 000 fichiers => 0,15 seconde.
 

Pièces jointes

  • Liste fichiers(2).xlsm
    19.4 KB · Affichages: 10
  • Bonjour.xlsx
    8.6 KB · Affichages: 4
  • Forum.xlsx
    8.6 KB · Affichages: 6

Discussions similaires

Réponses
1
Affichages
113

Membres actuellement en ligne

Statistiques des forums

Discussions
313 283
Messages
2 096 813
Membres
106 752
dernier inscrit
Tahiri1976