Ripeti i file in una cartella usando VBA?


236

Vorrei scorrere i file di una directory utilizzando in Excel 2010.

Nel ciclo, avrò bisogno di:

  • il nome file e
  • la data in cui il file è stato formattato.

Ho codificato quanto segue che funziona bene se la cartella non contiene più di 50 file, altrimenti è ridicolmente lenta (ne ho bisogno per funzionare con cartelle con> 10000 file). L'unico problema di questo codice è che l'operazione di ricerca file.namerichiede molto tempo.

Codice che funziona ma è troppo lento (15 secondi per 100 file):

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

Problema risolto:

  1. Il mio problema è stato risolto dalla soluzione seguente usando Dirin modo particolare (20 secondi per 15000 file) e per controllare il timestamp usando il comando FileDateTime.
  2. Tenendo conto di un'altra risposta da sotto i 20 secondi vengono ridotti a meno di 1 secondo.

Il tuo tempo iniziale sembra ancora lento per VBA. Stai usando Application.ScreenUpdating = false?
Michiel van der Blonk,

2
Sembra che manchi codeSet MyObj = New FileSystemObject
baldmosher

13
Trovo piuttosto triste che le persone si affrettino a chiamare l'FSO "lento", ma nessuno menziona la penalità prestazionale che potresti evitare usando semplicemente l'associazione anticipata invece delle chiamate in ritardo contro Object.
Mathieu Guindon,

Risposte:


46

Ecco invece la mia interpretazione come funzione:

'#######################################################################
'# 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
perché funzione, quando non viene restituito nulla? non è la stessa della risposta data da brettdj, tranne per il fatto che è racchiusa in una funzione
Shafeek,

253

Dirprende i caratteri jolly in modo da poter fare una grande differenza aggiungendo il filtro per testil fronte ed evitando di testare ogni file

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
GRANDE. Ciò ha appena migliorato l'autonomia da 20 secondi a <1 secondi. Questo è un grande miglioramento, poiché il codice verrà eseguito abbastanza spesso. GRAZIE!!
tyrex,

Potrebbe essere perché il ciclo Do while ... è meglio di mentre ... wend. maggiori informazioni qui stackoverflow.com/questions/32728334/…
Hila DG

6
Non penso per quel livello di miglioramento (20 - xxx volte) - Penso che sia il jolly a fare la differenza.
Brettdj,

DIR () non sembra restituire file nascosti.
hamish il

@hamish, puoi cambiare argomento per restituire diversi tipi di file (nascosto, sistema, ecc.) - consulta la documentazione MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Dir sembra essere molto veloce.

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
Ottimo, grazie mille. Uso Dir ma non sapevo che puoi usarlo anche in questo modo. Inoltre con il comando il FileDateTimemio problema è risolto.
tyrex,

4
Ancora una domanda. Potrei migliorare notevolmente la velocità se DIR si avvia in loop a partire dai file più recenti. Vedi un modo per farlo?
tyrex,

3
La mia ultima domanda è stata risolta dal seguente commento di Brettdj.
tyrex,

Dir lo farà notcomunque traverse the whole directory tree. In caso di necessità: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com

Dir verrà inoltre interrotto da altri comandi Dir, quindi se si esegue una subroutine contenente Dir, è possibile "ripristinarlo" nel proprio sub originale. L'uso di FSO secondo la domanda originale elimina questo problema. EDIT: appena visto il post di @LimaNightHawk qui sotto, stessa cosa
baldmosher

26

La funzione Dir è la strada da percorrere, ma il problema è che non è possibile utilizzare la Dirfunzione in modo ricorsivo , come indicato qui, verso il basso .

Il modo in cui l'ho gestito è usare la Dirfunzione per ottenere tutte le sottocartelle per la cartella di destinazione e caricarle in un array, quindi passare l'array in una funzione che ricorre.

Ecco una classe che ho scritto che realizza questo, include la possibilità di cercare filtri. ( Dovrai perdonare la notazione ungherese, questa è stata scritta quando era di gran moda. )

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

Se vorrei elencare i file trovati nella colonna, quale potrebbe essere un'implementazione di questo?
jechaviz,

@jechaviz Il metodo GetFileList restituisce una matrice di String. Probabilmente dovrai semplicemente scorrere sull'array e aggiungere gli elementi a ListView o qualcosa del genere. I dettagli su come mostrare gli elementi in una visualizzazione elenco probabilmente non rientrano nell'ambito di questo post.
LimaNightHawk,

6

Dir La funzione perde facilmente attenzione quando gestisco ed elaboro file da altre cartelle.

Ho ottenuto risultati migliori con il componente FileSystemObject.

Ecco un esempio completo qui:

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

Non dimenticare di impostare un riferimento in Visual Basic Editor su Microsoft Scripting Runtime (utilizzando Strumenti> Riferimenti)

Provaci!


Tecnicamente questo è il metodo che sta usando il richiedente, semplicemente non hanno i loro riferimenti inclusi che rallenterebbero questo metodo.
Marcucciboy2,

-2

Prova questo. ( LINK )

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
Utilizzando il nostro sito, riconosci di aver letto e compreso le nostre Informativa sui cookie e Informativa sulla privacy.
Licensed under cc by-sa 3.0 with attribution required.