Macro de VBA que busca archivos en varias subcarpetas
Tengo una macro, si pongo en la celda E1 el nombre del archivo, busco la macro a través del directorio C:\Users\Marek\Desktop\Makro\, lo encuentro y pongo los valores necesarios en celdas específicas de mi archivo original con macro.
¿Es posible hacer que esto funcione sin una ubicación de carpeta específica? Necesito algo que pueda buscar en C:\Users\Marek\Desktop\Makro\ con muchas subcarpetas.
Mi código:
Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text
If FName = False Then
'do nothing
Else
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Sólo por diversión, aquí hay un ejemplo con una función recursiva que (espero) debería ser un poco más sencilla de entender y usar con tu código:
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
Call TestSub(mySubFolder.Path)
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
Sub TestSub(ByVal s As String)
Debug.Print s
End Sub
Editar: así es como puede implementar este código en su libro de trabajo para lograr su objetivo.
Sub TestSub(ByVal s As String)
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name 'Or do whatever you want with the file
End If
Next
End Sub
Aquí, simplemente depuro el nombre del archivo encontrado, el resto depende de usted. ;)
Por supuesto, algunos dirían que es un poco torpe llamar dos veces a FileSystemObject, por lo que simplemente podría escribir su código de esta manera (depende de si desea compartimentar o no):
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
Este sub completará una colección con todos los archivos que coincidan con el nombre de archivo o patrón que ingrese.
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
If DoSubfolders then
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End If
End Sub
Uso:
Dim colFiles As New Collection
GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
'work with found files
End If
Si esto ayuda, también puedes usar FileSystemObject para recuperar todas las subcarpetas de una carpeta. Debe consultar la referencia "Microsot Scripting Runtime" para obtener Intellisense y utilizar la palabra clave "nueva".
Sub GetSubFolders()
Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Set f = fso.GetFolder("D:\Proj\")
For Each sf In f.SubFolders
'Code inside
Next
End Sub