Abrir todos los archivos "xlsm" en carpetas y sub

[Fonta11]

Buenas tardes y muchas gracias de antemano.

Tengo una macro que abre los archivos excel (xlsm) de una carpeta uno por uno y realiza algunas modificaciones y los cierra, el problema surge que los archivos también se encuentran en subcarpetas y necesitaría que estos también los abriera.

Tengo las dos macro, peor no se como juntar para que lo haga.

Esta macro copia los datos del archivo y los pasa a otro en común:

Sub ()

On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False

Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long, ultima As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Set SummarySheet = ThisWorkbook.Worksheets(1)

'INDICAR LA RUTA DONDE ESTÁN LOS ARCHIVOS (ACCESOS DIRECTOS "LNK")
FolderPath = "C:\Users\pedro\Desktop\CENSO\censos total\"
FileName = Dir(FolderPath & "*.lnk")

'ABRIR LOS ARCHIVOS DE UNO EN UNO
Do While FileName <> ""

Set WorkBk = Workbooks.Open(FolderPath & FileName) 

'PASAR LOS DATOS DE UNA HOJA A LA HOJA EN COMÚN

ultima = Range("A" & Rows.Count).End(xlUp).Row
If ultima < 5 Then ultima = 5
NRow = SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1
Set SourceRange = WorkBk.Worksheets(1).Range("A3:CO" & ultima)
Set DestRange = SummarySheet.Range("A" & NRow)
SourceRange.Select
Selection.Copy
ThisWorkbook.Activate
Worksheets(1).Select
Range("A" & NRow).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
NRow = NRow + DestRange.Rows.Count
WorkBk.Close savechanges:=False
FileName = Dir()

Loop
End Sub

y ESTA OTRA LA ENCONTRÉ EN ESTE FORO Y LO QUE HACE ES PONES EL NOMBRE DEL ARCHIVO Y LO BUSCA EN TODAS PARTES

Sub Abre_archivo()
Dim archivo As String
archivo = Trim(InputBox( _
"Indica el nombre del archivo que deseas abrir..." & vbCr & _
"(OJO: NO pongas la EXTension del archivo)")) & ".xlsm"
If archivo = ".xlsm" Then Exit Sub
Busca_archivo "C:\Users\pedro\Desktop\PROYE\", archivo
End Sub

Sub Busca_archivo(rutaBase As String, Optional archivo As String)
Dim nombre As String, cumple As Boolean, sDirs As Collection, nDirs As Long
Set sDirs = New Collection: sDirs.Add rutaBase: nDirs = 1
Do While nDirs <= sDirs.Count
rutaBase = sDirs(nDirs): nombre = Dir(rutaBase, vbDirectory + vbNormal)
Do While nombre <> ""
If nombre <> "." And nombre <> ".." Then
If (GetAttr(rutaBase & nombre) And vbDirectory) = vbDirectory Then
sDirs.Add rutaBase & nombre & "\"
Else
If LCase(nombre) = LCase(archivo) Then _
Shell Environ("comspec") & " /c """ & rutaBase & nombre & """", vbHide: _
cumple = True: Exit Do
End If: End If: nombre = Dir: Loop
If cumple Then Exit Do Else nDirs = nDirs + 1
Loop: If Not cumple Then MsgBox archivo & " NO existe !!!"
End Sub

ESPERO ME PUEDAN AYUDAR

MIL GRACIAS.

[Antoni]

Estas macros exploran una carpeta y todas las subcarpetas hasta el ultimo nivel. 

Ejecuta la macro ExpandirCarpeta previa adaptación de la variable CarpetaPrincipal a tus necesidades.

En la columna A se mostrarán los archivos xlsm y las subcarpetas por niveles, a partir de la columna B.

Solo tienes que recorrer la columna A, ir abriendo cada archivo y hacerle las modificaciones correspondientes. 

Dim FSO As Object, Fila2, Archivos

Sub ExplorarCarpeta()
'----------------------------------------------------------------------
CarpetaPrincipal = "D:\Documents and Settings\pc\Mis documentos\_Backup"
'----------------------------------------------------------------------
Application.ScreenUpdating = False
Cells.Clear
Fila2 = 0
'-- Carpeta
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSC = FSO.GetFolder(CarpetaPrincipal)
Set Archivos = FSC.Files
RecuperarArchivos
'-- Subcarpetas
ArchivosEnSubcarpetas CarpetaPrincipal, 2
Columna = 2
Do Until Cells(Rows.Count, Columna).End(xlUp) = ""
   For Fila = 1 To Cells(Rows.Count).End(xlUp).Row
      ArchivosEnSubcarpetas Cells(Fila, Columna), Columna + 1
   Next
   Columna = Columna + 1
Loop
End Sub

Private Sub ArchivosEnSubcarpetas(Carpeta, Columna)
Application.ScreenUpdating = False
Set FSC = FSO.GetFolder(Carpeta)
Set Carpetas = FSC.SubFolders
For Each Subcarpeta In Carpetas
   Fila = Fila + 1
   Cells(Fila, Columna) = Subcarpeta
   Set Archivos = Subcarpeta.Files
   RecuperarArchivos
Next
End Sub

Private Sub RecuperarArchivos()
For Each Archivo In Archivos
   If Mid(Archivo, InStrRev(Archivo, ".")) = ".xlsm" Then
      Fila2 = Fila2 + 1
      Cells(Fila2, 1) = Archivo
   End If
Next
End Sub

 

[Fonta11]

Muchas gracias Macro Antonio,

Lo único que pasa es que solo mira en la 1ª subcarpeta y en este caso están los archivos xlsm mas escondidos, es decir están en la subcarpeta de la subcarpeta de la subcarpeta. En definitiva que hay muchas carpetas previas antes de llegar al archivo.

Espero me puedas ayudar.

Gracias.

[Fonta11]

En 1/4/2016 at 19:26 , Macro Antonio dijo:

Estas macros exploran una carpeta y todas las subcarpetas hasta el ultimo nivel. 

Ejecuta la macro ExpandirCarpeta previa adaptación de la variable CarpetaPrincipal a tus necesidades.

En la columna A se mostrarán los archivos xlsm y las subcarpetas por niveles, a partir de la columna B.

Solo tienes que recorrer la columna A, ir abriendo cada archivo y hacerle las modificaciones correspondientes. 

Dim FSO As Object, Fila2, Archivos

Sub ExplorarCarpeta()
'----------------------------------------------------------------------
CarpetaPrincipal = "D:\Documents and Settings\pc\Mis documentos\_Backup"
'----------------------------------------------------------------------
Application.ScreenUpdating = False
Cells.Clear
Fila2 = 0
'-- Carpeta
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSC = FSO.GetFolder(CarpetaPrincipal)
Set Archivos = FSC.Files
RecuperarArchivos
'-- Subcarpetas
ArchivosEnSubcarpetas CarpetaPrincipal, 2
Columna = 2
Do Until Cells(Rows.Count, Columna).End(xlUp) = ""
   For Fila = 1 To Cells(Rows.Count).End(xlUp).Row
      ArchivosEnSubcarpetas Cells(Fila, Columna), Columna + 1
   Next
   Columna = Columna + 1
Loop
End Sub

Private Sub ArchivosEnSubcarpetas(Carpeta, Columna)
Application.ScreenUpdating = False
Set FSC = FSO.GetFolder(Carpeta)
Set Carpetas = FSC.SubFolders
For Each Subcarpeta In Carpetas
   Fila = Fila + 1
   Cells(Fila, Columna) = Subcarpeta
   Set Archivos = Subcarpeta.Files
   RecuperarArchivos
Next
End Sub

Private Sub RecuperarArchivos()
For Each Archivo In Archivos
   If Mid(Archivo, InStrRev(Archivo, ".")) = ".xlsm" Then
      Fila2 = Fila2 + 1
      Cells(Fila2, 1) = Archivo
   End If
Next
End Sub

 

Gracias MacroAntonio, pero necesito que mire en más subcarpetas que hay, es decir, hay carpetas que tiene subcarpetas dentro y mas subcarpetas dentro de las subcarpetas

 

Espero haberme explicado.