Passare in rassegna i file in una cartella usando VBA?

Vorrei scorrere i file di una directory usando vba in Excel 2010.

Nel ciclo, avrò bisogno

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

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

Il codice 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 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 da sotto i 20 secondi vengono ridotti a meno di 1 secondo.

Ecco la mia interpretazione come una funzione invece:

 '####################################################################### '# 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 

Dir prende le wild card in modo da poter fare una grande differenza aggiungendo il filtro per il test in avanti 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 

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 

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

Il modo in cui l’ho gestito è quello di utilizzare la funzione Dir per ottenere tutte le sottocartelle della cartella di destinazione e caricarle in una matrice, quindi passare l’array in una funzione che ricorre.

Ecco una class che ho scritto che realizza questo, include la possibilità di cercare filtri. ( Dovrai perdonare la notazione ungherese, questo è stato scritto 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 

Dir funzione Dir perde facilmente la messa a fuoco quando gestisco ed elabora file da altre cartelle.

Ho ottenuto risultati migliori con il componente FileSystemObject .

L’esempio completo è riportato qui:

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

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

Provaci!

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