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.
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
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.