Parcourez les fichiers d'un dossier à l'aide de VBA?


236

Je voudrais parcourir les fichiers d'un répertoire en utilisant dans Excel 2010.

Dans la boucle, j'aurai besoin de:

  • le nom du fichier, et
  • la date à laquelle le fichier a été formaté.

J'ai codé ce qui suit qui fonctionne bien si le dossier ne contient pas plus de 50 fichiers, sinon c'est ridiculement lent (j'en ai besoin pour travailler avec des dossiers avec> 10000 fichiers). Le seul problème de ce code est que l'opération de recherche file.nameprend beaucoup de temps.

Code qui fonctionne mais qui est waaaaaay trop lent (15 secondes pour 100 fichiers):

Sub LoopThroughFiles()
   Dim MyObj As Object, MySource As Object, file As Variant
   Set MySource = MyObj.GetFolder("c:\testfolder\")
   For Each file In MySource.Files
      If InStr(file.name, "test") > 0 Then
         MsgBox "found"
         Exit Sub
      End If
   Next file
End Sub

Problème résolu:

  1. Mon problème a été résolu par la solution ci-dessous en utilisant Dird'une manière particulière (20 secondes pour 15000 fichiers) et pour vérifier l'horodatage à l'aide de la commande FileDateTime.
  2. La prise en compte d'une autre réponse en dessous des 20 secondes est réduite à moins d'une seconde.

Votre temps initial semble encore lent pour VBA. Utilisez-vous Application.ScreenUpdating = false?
Michiel van der Blonk

2
Vous semblez manquer codeSet MyObj = New FileSystemObject
baldmosher

13
Je trouve plutôt triste que les gens appellent rapidement le FSO "lent", mais personne ne mentionne la pénalité de performance que vous pourriez éviter en utilisant simplement une liaison anticipée au lieu d'appels tardifs contre Object.
Mathieu Guindon

Réponses:


46

Voici mon interprétation en tant que fonction à la place:

'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# /programming/10380312/loop-through-files-in-a-folder-using-vba
'#######################################################################
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String

    Dim StrFile As String
    'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile

    StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir

    Loop

End Function

25
pourquoi fonctionner, quand rien n'est retourné? n'est-ce pas la même que la réponse donnée par brettdj, sauf qu'elle est enfermée dans une fonction
Shafeek

253

Dirprend des caractères génériques afin que vous puissiez faire une grande différence en ajoutant le filtre à testl'avance et en évitant de tester chaque fichier

Sub LoopThroughFiles()
    Dim StrFile As String
    StrFile = Dir("c:\testfolder\*test*")
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir
    Loop
End Sub

29
GÉNIAL. Cela a juste amélioré le temps d'exécution de 20 secondes à <1 seconde. C'est une grande amélioration, car le code sera exécuté assez souvent. MERCI!!
Tyrex

C'est peut-être parce que la boucle Do while ... est meilleure que while ... wend. plus d'infos ici stackoverflow.com/questions/32728334/…
Hila DG

6
Je ne pense pas que par ce niveau d'amélioration (20 - xxx fois) - je pense que son caractère générique fait une différence.
brettdj

DIR () ne semble pas retourner les fichiers cachés.
hamish

@hamish, vous pouvez changer son argument pour renvoyer différents types de fichiers (cachés, système, etc.) - voir la documentation MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Dir semble être très rapide.

Sub LoopThroughFiles()
    Dim MyObj As Object, MySource As Object, file As Variant
   file = Dir("c:\testfolder\")
   While (file <> "")
      If InStr(file, "test") > 0 Then
         MsgBox "found " & file
         Exit Sub
      End If
     file = Dir
  Wend
End Sub

3
Super, merci beaucoup. J'utilise Dir mais je ne savais pas que vous pouvez également l'utiliser de cette façon. En plus avec la commande FileDateTimemon problème est résolu.
Tyrex

4
Encore une question. Je pourrais considérablement améliorer la vitesse si DIR faisait une boucle en commençant par les fichiers les plus récents. Voyez-vous un moyen de le faire?
Tyrex

3
Ma dernière question a été réglée par le commentaire ci-dessous de brettdj.
Tyrex

Dir le fera notcependant traverse the whole directory tree. En cas de besoin: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com

Dir sera également interrompu par d'autres commandes Dir, donc si vous exécutez un sous-programme contenant Dir, il peut le "réinitialiser" dans votre sous-répertoire d'origine. L'utilisation de FSO selon la question d'origine élimine ce problème. EDIT: vient de voir le post de @LimaNightHawk ci-dessous, même chose
baldmosher

26

La fonction Dir est le chemin à parcourir, mais le problème est que vous ne pouvez pas utiliser la Dirfonction récursivement , comme indiqué ici, vers le bas .

La façon dont j'ai géré cela consiste à utiliser la Dirfonction pour obtenir tous les sous-dossiers du dossier cible et les charger dans un tableau, puis passer le tableau dans une fonction qui se reproduit.

Voici une classe que j'ai écrite qui accomplit cela, elle inclut la possibilité de rechercher des filtres. ( Vous devrez pardonner la notation hongroise, cela a été écrit quand c'était à la mode. )

Private m_asFilters() As String
Private m_asFiles As Variant
Private m_lNext As Long
Private m_lMax As Long

Public Function GetFileList(ByVal ParentDir As String, Optional ByVal sSearch As String, Optional ByVal Deep As Boolean = True) As Variant
    m_lNext = 0
    m_lMax = 0

    ReDim m_asFiles(0)
    If Len(sSearch) Then
        m_asFilters() = Split(sSearch, "|")
    Else
        ReDim m_asFilters(0)
    End If

    If Deep Then
        Call RecursiveAddFiles(ParentDir)
    Else
        Call AddFiles(ParentDir)
    End If

    If m_lNext Then
        ReDim Preserve m_asFiles(m_lNext - 1)
        GetFileList = m_asFiles
    End If

End Function

Private Sub RecursiveAddFiles(ByVal ParentDir As String)
    Dim asDirs() As String
    Dim l As Long
    On Error GoTo ErrRecursiveAddFiles
    'Add the files in 'this' directory!


    Call AddFiles(ParentDir)

    ReDim asDirs(-1 To -1)
    asDirs = GetDirList(ParentDir)
    For l = 0 To UBound(asDirs)
        Call RecursiveAddFiles(asDirs(l))
    Next l
    On Error GoTo 0
Exit Sub
ErrRecursiveAddFiles:
End Sub
Private Function GetDirList(ByVal ParentDir As String) As String()
    Dim sDir As String
    Dim asRet() As String
    Dim l As Long
    Dim lMax As Long

    If Right(ParentDir, 1) <> "\" Then
        ParentDir = ParentDir & "\"
    End If
    sDir = Dir(ParentDir, vbDirectory Or vbHidden Or vbSystem)
    Do While Len(sDir)
        If GetAttr(ParentDir & sDir) And vbDirectory Then
            If Not (sDir = "." Or sDir = "..") Then
                If l >= lMax Then
                    lMax = lMax + 10
                    ReDim Preserve asRet(lMax)
                End If
                asRet(l) = ParentDir & sDir
                l = l + 1
            End If
        End If
        sDir = Dir
    Loop
    If l Then
        ReDim Preserve asRet(l - 1)
        GetDirList = asRet()
    End If
End Function
Private Sub AddFiles(ByVal ParentDir As String)
    Dim sFile As String
    Dim l As Long

    If Right(ParentDir, 1) <> "\" Then
        ParentDir = ParentDir & "\"
    End If

    For l = 0 To UBound(m_asFilters)
        sFile = Dir(ParentDir & "\" & m_asFilters(l), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem)
        Do While Len(sFile)
            If Not (sFile = "." Or sFile = "..") Then
                If m_lNext >= m_lMax Then
                    m_lMax = m_lMax + 100
                    ReDim Preserve m_asFiles(m_lMax)
                End If
                m_asFiles(m_lNext) = ParentDir & sFile
                m_lNext = m_lNext + 1
            End If
            sFile = Dir
        Loop
    Next l
End Sub

Si je souhaite répertorier les fichiers trouvés dans la colonne, quelle pourrait être une implémentation de cela?
jechaviz

@jechaviz La méthode GetFileList renvoie un tableau de String. Vous feriez probablement juste parcourir le tableau et ajouter les éléments à un ListView, ou quelque chose comme ça. Les détails sur la façon d'afficher des éléments dans une vue de liste dépassent probablement la portée de ce message.
LimaNightHawk

6

Dir la fonction perd le focus facilement lorsque je gère et traite des fichiers à partir d'autres dossiers.

J'ai obtenu de meilleurs résultats avec le composant FileSystemObject.

Un exemple complet est donné ici:

http://www.xl-central.com/list-files-fso.html

N'oubliez pas de définir une référence dans Visual Basic Editor à Microsoft Scripting Runtime (en utilisant Outils> Références)

Essaie!


Techniquement, c'est la méthode que le demandeur utilise, ils n'ont tout simplement pas leurs références incluses, ce qui ralentirait cette méthode.
Marcucciboy2

-2

Essaye celui-là. ( LIEN )

Private Sub CommandButton3_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True

End Sub
En utilisant notre site, vous reconnaissez avoir lu et compris notre politique liée aux cookies et notre politique de confidentialité.
Licensed under cc by-sa 3.0 with attribution required.