Passa in rassegna i file in una cartella usando VBA?

Question

Vorrei un ciclo tra i file di una directory utilizzando vba in Excel 2010.

Nel ciclo, ho bisogno

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

Ho codificato il seguente che funziona bene se la cartella non ha più di 50 file, altrimenti è ridicolmente lento (ho bisogno di lavorare con cartelle con> 10000 file). L'unico problema di questo codice è che l'operazione di ricerca di file.name richiede molto tempo.

codice che funziona, ma è waaaaaay troppo lenta (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 dal soluzione sotto usando Dir in un modo particolare (20 secondi per 15000 file) e per controllare il timestamp usando il comando FileDateTime.
2. Prendendo in considerazione un'altra risposta dal basso, i 20 secondi vengono ridotti a meno di 1 secondo.

Answer 1

Ecco la mia interpretazione come funzione invece:

funzione

'####################################################################### 
'# LoopThroughFiles 
'# Function to Loop through files in current directory and return filenames 
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile 
'# https://stackoverflow.com/questions/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 

Answer 2

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 

Answer 3

Dir prende jolly così si potrebbe fare una grande differenza di aggiungere il filtro per test in anticipo ed evitare il test 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 

Answer 4

La funzione Dir è la strada da percorrere, ma il problema è che non è possibile utilizzare la funzione Dir in modo ricorsivo, come indicato here, towards the bottom.

Il modo in cui ho gestito questo è quello di utilizzare la funzione Dir per ottenere tutte le sottocartelle per la cartella di destinazione e caricarli in un array, quindi passare la matrice in una funzione che recurses.

Ecco una classe che ho scritto che realizza ciò, include la possibilità di cercare filtri. (Dovrete perdonare l'notazione ungherese, questo è stato scritto quando era tutta la rabbia.)

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 

Answer 5

Dir perde l'attivazione facilmente quando gestisco ed elabora file da altre cartelle.

Ho ottenuto risultati migliori con il componente FileSystemObject.

esempio completo è qui dato:

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

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

Dare è una prova!

Answer 6

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