Macro en excel para sacar un rango de diferentes libros y diferentes carpetas.
Para Dante Amor.
Necesito sacar un rango de celdas de varios archivos iguales pero que están en carpetas y subcarpetas. He visto y lo he hecho pero siempre de una carpeta y no de subcarpetas, ¿se puede hacer? Los archivos tienen distintos nombres pero siempre tienen el mismo formato, osea el rango a sacar es g19:k250,
Ejemplo: archivos de nombres distintos biomasa.xls, porosidad.xls que están en una carpeta llamada "resumen" dentro de esa carpeta hay una subcarpeta que se llama "MDF" y adentro de MDF otro archivo que se llama porosidad2.xls de todos los xls debo sacar para analizar los rangos G19: K250 y ponerlos uno debajo de otro.
Esto es lo que hice: pero solo busca de una carpeta:
Sub copia_hojas()
'------------------
'by niko
'------------------
Dim ws As Worksheet, iFile$, iRow&, mFolder$
Set ws = ActiveSheet
ws.Range(ws.[a1], ws.[a1].SpecialCells(11)).Offset(1).Delete xlShiftUp
mFolder = ThisWorkbook.Path & "\resumen de acciones"
iFile = Dir(mFolder & "\*.xls*")
iRow = 2
Do Until iFile = ""
With ws.Cells(iRow, "a").Resize(150, 7)
.Formula = "=if('" & mFolder & "\[" & iFile & "]5porque'!g19 ="""", """" ,'" & mFolder & "\[" & iFile & "]5porque'!g19)"
.Value = .Value
End With
iFile = Dir
iRow = iRow + 150
tope = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
For f = tope To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(f)) = 0 Then Rows(f).EntireRow.Delete
Next
Columns("A:A").WrapText = True
Columns("B:B").WrapText = True
Columns("C:C").WrapText = True
Columns("D:D").WrapText = True
Loop
End Sub
Excelente foro.
1 respuesta
H o l a:
Te anexo la macro actualizada, puse en un arreglo los folders que quieres revisar, si necesitas otro subfolder lo puedes agregar al arreglo.
La macro para sacar la información de un archivo sigue igual, solamente cambiaron los parámetros de carpeta y archivo.
Observa que al principio de la macro deben estar declaradas las variables públicas:
Public ws, iRow, mFolder, iFile
'
Sub copia_hojas()
'------------------
'by niko
'Act.Por.Dante Amor
'------------------
Dim ws As Worksheet, iFile$, iRow&, mFolder$
Set ws = ActiveSheet
ws.Range(ws.[a1], ws.[a1].SpecialCells(11)).Offset(1).Delete xlShiftUp
iRow = 2
Folders = Array(ThisWorkbook.Path & "\resumen de acciones", _
ThisWorkbook.Path & "\resumen de acciones\MDF")
For i = LBound(Folders) To UBound(Folders)
mFolder = Folders(i)
iFile = Dir(mFolder & "\*.xls*")
Do Until iFile = ""
Call copiar(ws, iRow, mFolder, iFile)
iFile = Dir
Loop
Next
'
MsgBox "Fin"
End Sub
'
Sub copiar(ws, iRow, mFolder, iFile)
With ws.Cells(iRow, "a").Resize(150, 7)
.Formula = "=if('" & mFolder & "\[" & iFile & "]5porque'!g19 ="""", """" ,'" & mFolder & "\[" & iFile & "]5porque'!g19)"
.Value = .Value
End With
iRow = iRow + 150
tope = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
For f = tope To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(f)) = 0 Then Rows(f).EntireRow.Delete
Next
Columns("A:A").WrapText = True
Columns("B:B").WrapText = True
Columns("C:C").WrapText = True
Columns("D:D").WrapText = True
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
Perfecto funciona! Ahora si quisiera poner otra subcarpeta ejemplo:
Resumen de acciones\MDF\niko como lo pongo porque me da error
Con mucho gusto te ayudo con todas tus peticiones.
Valora adecuadamente esta respuesta y crea una nueva pregunta en el tema de microsoft excel, en el desarrollo de la pregunta escribe: "para Dante Amor"
