Tengo problemas para extraer los datos de los archivos de Excel a uno solo con la marco que dejaste
Tengo en una carpeta todos los archivos de Excel que deseo bajarles la información, pero utilizo la macro que dejaste y no me ha funcionado, ¿me podrías colaborar por favor?
La macro que estoy usando es:
Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja1")
On Error Resume Next
Do While archi <> ""
If InStr(1, archi, "nuevo") = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(1).Select
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy _
h1.Range("A" & h1.Range("A1").SpecialCells(xlLastCell).Row + 1)
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub
1 Respuesta
Respuesta de Dante Amor
1
Para que se más práctico pon los libros en una carpeta diferente a donde tienes el libro con la macro y prueba con esta:
Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = "C:\trabajo\"
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja1")
'On Error Resume Next
Do While archi <> ""
'If InStr(1, archi, "nuevo") = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(1).Select
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy _
h1.Range("A" & h1.Range("A1").SpecialCells(xlLastCell).Row + 1)
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
'End If
archi = Dir()
Loop
End SubCambia "C:\trabajo\" por la carpeta donde tienes tus archivos.
Señor dante necesito de su colaboración si fuera tan amable con el hilo Como se crea un formulario en vba excel - Jhonja Clavijo