Modificar macro que extrae datos devarios archivos
Podría alguien ayudarme a modificar una macro que extrae datos.
2 respuestas
Estoy aquí para ayudarte a modificar tu macro para extraer datos de varios archivos. Por favor, proporciona más detalles sobre qué tipo de datos deseas extraer y cómo se encuentran estructurados en los archivos. Además, si tienes algún código existente que podamos utilizar como punto de partida, por favor compártelo para poder entender mejor tu situación y brindarte una solución adecuada.
Buenas tardes,
Encontré una macro del Sr. Dante en internet la cual extrae información de varios archivos pero no tiene un rango de fila ni columna las cuales se necesitan, pero necesito que primero compare la fecha (mes y año) de una celda que esta en archivo principal contra la fecha (mes y año) de una celda que esta en los archivos de donde va a extraer toda la información.
Sub Importar_Datos()
'
' Por.Dante Amor
'
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Valores")
Set h2 = l1.Sheets("Resumen")
h2.Cells.ClearContents
'
ruta = h1.[B5]
hoja = h1.[B6]
fila = h1.[B7]
colu = h1.[B8]
'
mensaje = validaciones(ruta, hoja, fila, colu)
If mensaje <> "" Then
MsgBox mensaje, vbExclamation, "IMPORTAR ARCHIVOS"
Exit Sub
End If
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = False
Application.Calculation = xlCalculationManual
'
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
arch = Dir(ruta & "*.xls*")
i = 0
Do While arch <> ""
i = i + 1
Application.StatusBar = "Importando Libro : " & i & " de : " & n
Set l2 = Workbooks.Open(ruta & arch)
existe = False
If IsNumeric(hoja) Then
If l2.Sheets.Count >= hoja Then
existe = True
Set h22 = l2.Sheets(hoja)
Else
End If
Else
For Each h In l2.Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Set h22 = l2.Sheets(hoja)
Exit For
End If
Next
End If
'
If existe Then
u22 = h22.Range(colu & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h22.Rows(fila & ":" & u22).Copy
h2.Range("A" & u2).PasteSpecial xlValues
End If
'
l2.Close False
arch = Dir()
Loop
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
'
MsgBox "Proceso terminado, archivos importados a la hoja resumen", vbInformation, "IMPORTAR ARCHIVOS"
End SubSAludos,
MG
Tengo archivos de varios meses en una carpeta y necesito que la macro extraiga solo la información del mes que deseo trabajar.
Aquí tienes una versión modificada de la macro:
Sub Importar_Datos()
'
' Por.Dante Amor
'
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Valores")
Set h2 = l1.Sheets("Resumen")
h2.Cells.ClearContents
'
ruta = h1.[B5]
hoja = h1.[B6]
fila = h1.[B7]
colu = h1.[B8]
fechaBusqueda = h1.[B9] ' Agrega la celda de la fecha que deseas buscar en el archivo principal
'
mensaje = validaciones(ruta, hoja, fila, colu)
If mensaje <> "" Then
MsgBox mensaje, vbExclamation, "IMPORTAR ARCHIVOS"
Exit Sub
End If
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = False
Application.Calculation = xlCalculationManual
'
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
arch = Dir(ruta & "*.xls*")
i = 0
Do While arch <> ""
i = i + 1
Application.StatusBar = "Importando Libro : " & i & " de : " & n
Set l2 = Workbooks.Open(ruta & arch)
existe = False
If IsNumeric(hoja) Then
If l2.Sheets.Count >= hoja Then
existe = True
Set h22 = l2.Sheets(hoja)
End If
Else
For Each h In l2.Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Set h22 = l2.Sheets(hoja)
Exit For
End If
Next
End If
'
If existe Then
u22 = h22.Range(colu & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
' Agregar la condición de comparación de fechas
fechaArchivo = h22.Range("A1").Value ' Suponiendo que la fecha está en la columna A y en la primera fila del archivo
If Month(fechaArchivo) = Month(fechaBusqueda) And Year(fechaArchivo) = Year(fechaBusqueda) Then
h22.Rows(fila & ":" & u22).Copy
h2.Range("A" & u2).PasteSpecial xlValues
End If
End If
'
l2.Close False
arch = Dir()
Loop
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
'
MsgBox "Proceso terminado, archivos importados a la hoja resumen", vbInformation, "IMPORTAR ARCHIVOS"
End Sub
Aquí hay unos ejemplos:
Ordenar datos en una matriz - YouTube
Anidar la función SI - YouTube
Sal u dos
Dante Amor
Saludos, Sr. Dante
Gracias anticipadas por tomarmi solicitud.
La primera macro podría servirme para la extracción de información que esta en las filas y columnas de varios archivos, solo hace falta incluir una condición la cual compare la fecha(mes) que este en una celda especifica del archivo principal contra la fecha(mes) que esta en una celda especifica en los archivos de origen.
Saludos,
MG
Sr Rafael, por casualidad espefico a la macro desde cual fila hasta que columna leer?
para mi es importante el rango de fila y columna.
Gracias anticipadas,
MG
Saludos,
MG
SAludos,
¿Tiene algún inconveniente para ayudarme?
MG
Saludos
¿Tiene algún inconveniente para ayudarme?
Ningún inconveniente.
Las explicaciones están en los enlaces.
Sal u dos
Dante Amor
Buenas tardes Sr.DAnte
Los enlaces hablan de celdas especificas, es decir A8 y i41, yo necesito que la macro tome las informaciones desde una celda hasta otra celda.
Ej: libro A= donde se colocara la macro para almacenar toda la información.
Libros B-C-D= donde están los datos que la macro extraerá los cuales están desde la celda A8 hasta la celda K41. La macro debe tomar toda la información del libro B y llevarlo al libro A, luego toma las del libro C y luego las del libro D
Gracias MG
En resumen, Sr. DAnte, lo que deseo es unir todas las informaciones que están en varios libros en un solo libro.
MG
Sr. Dante la macro que esta en el link crea un nuevo libro y yo necesito que ponga la información en un libro especifico llamado ¨¨Agrupado¨¨
De todas forma no saco la información.
Le envíe a su correo tres libros como ejemplo.
Libro llamado ¨¨Agrupado¨¨
Libros donde están las informaciones ¨¨caja chica¨¨
No tengo ningún correo, tal vez se lo enviaste a alguien más.
Ese fue el que encontré en su canal.
Años atrás yo le llegue a enviar varios archivos a este correo y ud.me ayudo.
Te paso la macro:
Sub Agrupar()
'Por Dante Amor
'
Dim sh1 As Worksheet, sh2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim arch As String
Dim i As Long
Dim c As Range
'
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set sh1 = wb1.Sheets("AGRUPADO")
'
arch = Dir(wb1.Path & "\" & "*.xls*")
'
i = 8
Do While arch <> ""
If arch <> wb1.Name Then
Set wb2 = Workbooks.Open(wb1.Path & "\" & arch)
Set sh2 = wb2.Sheets(1)
For Each c In sh2.Range("A8:A41")
If c.Value <> "" Then
sh1.Range("A" & i).Resize(1, 9).Value = c.Resize(1, 9).Value
i = i + 1
End If
Next
wb2.Close False
End If
arch = Dir()
Loop
'
Application.ScreenUpdating = True
End SubLo nuevo:
Sal u dos
Dante Amor