¿Pasa los archivos en una carpeta usando VBA?

Question

me gustaría bucle a través de los archivos de un directorio utilizando vba en Excel 2010.

En el bucle, necesitaré

• el nombre de archivo y
• la fecha en que el archivo fue formateado.

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

El código que funciona, pero es waaaaaay demasiado lento (15 segundos por cada 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. Mi problema ha sido resuelto por la solución a continuación usando Dir de una manera particular (20 segundos para 15000 archivos) y para verificar la marca de tiempo utilizando el comando FileDateTime.
2. Teniendo en cuenta otra respuesta de debajo, los 20 segundos se reducen a menos de 1 segundo.

Answer 1

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

función

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

Answer 3

Dir toma comodines por lo que podría hacer una gran diferencia de añadir el filtro para test por adelantado y evitar las pruebas de 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 

Answer 4

La función Dir es el camino a seguir, pero el problema es que no puede usar la función Dir recursivamente, como se indica here, towards the bottom.

La forma en que he manejado esto es usar la función Dir 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 posibilidad de buscar filtros. (Vas a tener que valga la notación húngara, esto fue escrito cuando era el último grito.)

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 pierde el foco fácilmente cuando manejo y proceso archivos de otras carpetas.

He obtenido mejores resultados con el componente FileSystemObject.

Ejemplo completo se da aquí:

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

No se olvide de establecer una referencia en el Editor de Visual Basic de Microsoft Scripting Runtime (mediante el uso de Herramientas> Referencias)

Dar Es un intento!

Answer 6

Pruebe este. (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