excel - subcarpetas - macro para obtener ruta de un archivo

Recorrer los archivos en una carpeta usando VBA?

Question

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

En el bucle, necesitaré

• el nombre del archivo, y
• La fecha en la 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 lenta (necesito que trabaje con carpetas con> 10000 archivos). El único problema de este código es que la operación para buscar file.name toma mucho tiempo.

Código que funciona pero es 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 se resolvió con la solución a continuación usando Dir de una manera particular (20 segundos para 15000 archivos) y para verificar la marca de tiempo usando el comando FileDateTime .
2. Teniendo en cuenta otra respuesta por debajo de los 20 segundos, se reduce a menos de 1 segundo.

Answer 1

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

La función Dir es el camino a seguir, pero el problema es que no se puede usar recursivamente la función Dir , como se indica aquí, hacia la parte inferior .

La forma en que he manejado esto es usar la función Dir para obtener todas las subcarpetas de 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

Answer 4

Prueba 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

Answer 5

Dir función Dir pierde el enfoque 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 (utilizando Herramientas> Referencias)

¡Darle una oportunidad!

Answer 6

Dir toma comodines para que pueda hacer una gran diferencia al agregar el filtro para la test por adelantado 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