¿Recorrer los archivos en una carpeta usando VBA?


236

Me gustaría recorrer los archivos de un directorio usando en Excel 2010.

En el bucle, necesitaré:

  • el nombre del archivo y
  • la fecha en que se formateó el archivo.

He codificado lo siguiente, que funciona bien si la carpeta no tiene más de 50 archivos, de lo contrario es ridículamente lento (necesito que funcione con carpetas con> 10000 archivos). El único problema de este código es que la operación de búsqueda file.namelleva mucho tiempo.

Código que funciona pero que es demasiado lento (15 segundos por 100 archivos):

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 resuelto:

  1. La solución a continuación solucionó mi problema utilizando Diruna forma particular (20 segundos para 15000 archivos) y para verificar la marca de tiempo utilizando el comando FileDateTime.
  2. Teniendo en cuenta otra respuesta desde abajo, los 20 segundos se reducen a menos de 1 segundo.

Su tiempo inicial parece lento para VBA todavía. ¿Está utilizando Application.ScreenUpdating = false?
Michiel van der Blonk

2
Parece que te falta codeSet MyObj = New FileSystemObject
baldmosher

13
Me parece bastante triste que la gente llame rápidamente al FSO "lento", pero nadie menciona la penalización de rendimiento que podría evitar simplemente usando el enlace temprano en lugar de las llamadas con retraso Object.
Mathieu Guindon

Respuestas:


46

Aquí está mi interpretación como una función en su lugar:

'#######################################################################
'# 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
¿Por qué función, cuando no se devuelve nada? no es lo mismo que la respuesta dada por brettdj, excepto que está incluida en una función
Shafeek

253

Dirtoma comodines para que pueda hacer una gran diferencia al agregar el filtro por testadelantado y evitar probar cada archivo

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
EXCELENTE. Esto solo mejoró el tiempo de ejecución de 20 segundos a <1 segundo. Esa es una gran mejora, ya que el código se ejecutará con bastante frecuencia. ¡¡GRACIAS!!
tyrex

Podría ser porque el bucle Do while ... es mejor que while ... wend. más información aquí stackoverflow.com/questions/32728334/…
Hila DG

66
No creo por ese nivel de mejora (20 - xxx veces) - Creo que es el comodín haciendo la diferencia.
brettdj

DIR () no parece devolver archivos ocultos.
hamish

@hamish, puede cambiar su argumento para devolver diferentes tipos de archivos (ocultos, sistema, etc.); consulte la documentación de MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Dir parece ser muy rápido.

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
Genial, muchas gracias. Yo uso Dir pero no sabía que también puedes usarlo de esa manera. Además con el comando FileDateTimemi problema está resuelto.
tyrex

44
Todavía una pregunta. Podría mejorar severamente la velocidad si DIR iniciara un ciclo comenzando con los archivos más recientes. ¿Ves alguna forma de hacer esto?
tyrex

3
Mi última pregunta ha sido resuelta por el comentario a continuación de brettdj.
tyrex

Dir lo hará notsin embargo traverse the whole directory tree. En caso de que sea necesario: analystcave.com/vba-dir-function-how-to-traverse-directories/...
AnalystCave.com

Dir también se verá interrumpido por otros comandos Dir, por lo que si ejecuta una subrutina que contiene Dir, puede "restablecerla" en su sub original. El uso de FSO según la pregunta original elimina este problema. EDITAR: acabo de ver la publicación de @LimaNightHawk a continuación, lo mismo
baldmosher

26

La función Dir es el camino a seguir, pero el problema es que no puede usar la Dirfunción de forma recursiva , como se indica aquí, hacia abajo .

La forma en que manejé esto es usar la Dirfunción para obtener todas las subcarpetas para la carpeta de destino y cargarlas en una matriz, luego pasar la matriz a una función que se repite.

Aquí hay una clase que escribí que logra esto, incluye la capacidad de buscar filtros. ( Tendrás que perdonar la notación húngara, esto se escribió cuando estaba de 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

Si quisiera enumerar los archivos encontrados en la columna, ¿cuál podría ser una implementación de esto?
jechaviz

@jechaviz El método GetFileList devuelve una matriz de String. Probablemente solo iteraría sobre la matriz y agregaría los elementos a ListView, o algo así. Los detalles sobre cómo mostrar elementos en una vista de lista probablemente estén fuera del alcance de esta publicación.
LimaNightHawk

6

Dir La función pierde el foco fácilmente cuando manejo y proceso archivos de otras carpetas.

He obtenido mejores resultados con el componente FileSystemObject.

El ejemplo completo se da aquí:

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

No olvide establecer una referencia en el Editor de Visual Basic para Microsoft Scripting Runtime (usando Herramientas> Referencias)

¡Darle una oportunidad!


Técnicamente, este es el método que está utilizando el autor de la pregunta, simplemente no tienen sus referencias incluidas, lo que estaría ralentizando este método.
Marcucciboy2

-2

Prueba este. ( ENLACE )

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
Al usar nuestro sitio, usted reconoce que ha leído y comprende nuestra Política de Cookies y Política de Privacidad.
Licensed under cc by-sa 3.0 with attribution required.