Macro que copie un rango de datos de varios archivos, con una hoja en común y en la columna siguiente el nombre de los archivos.
Mis estimados amig@s.
Me preguntaba si existe una macros, la misma que se encargaria de extraer datos de un Rango cual sea, ejemplo (A2:B2, A3:B3,...) de varios libros( Archivo1, Archivo2,...). Todos ellos con una hoja en "comun". Luego en la siguiente columna ejemplo "C" colocar el nombre del archivo al cual se le extrajo dicho informacion, debo mencionar que los archivos se encuentan en una carpeta, les dejo un ejemplo de como seria.
Gracias de antemano por el tiempo servido.
Saludos
2 Respuestas
Envíame 3 archivos, el archivo con la macro y 2 archivos más que contienen el rango a extraer, me explicas cuál es el problema.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “robert farfan” y el título de esta pregunta.
¡Gracias! buenos días.!
Las disculpas del caso, por el no haber respondido antes, por problemas técnicos con el computador.
Y volviendo al trabajo de la macros compartida, si me funciona a la perfección, en los archivos que tenia en una carpeta, después de que se le quitara las macros que traían cada una de ellas, incorporadas, quiero creer que se generaba un error al correrlo. por eso solo me aparecía el nombre del ultimo archivo de la carpeta.
Si se pudiera mejorar. estaría muy agradecido.
Pero si, agradezco el tiempo que se tomo para responder mi pregunta.
Gracias..!
Éxitos en todo.!
No cabe duda que en esta pagina si apoyan.......Saludos para tod@s...
Pregunta respondida con éxito..!
Anexo la última versión de la macro, solamente como información de que la macro sí funcionaba.
Sub Copiar_Un_Rango()
'---
' Por.Dante Amor
'---
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1") 'hoja destino
col = "A" 'columna destino
rango = "A3:D7" 'rango a extraer
num = "Hoja1" 'hoja origen, nombre de la hoja especial
'
ruta = l1.Path & "\"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1)
End With
'
arch = Dir(cp & "\" & "*.xls*")
Set r = Range(rango)
ncol = r.Columns.Count
nrow = r.Rows.Count - 1
Do While arch <> ""
Set l2 = Workbooks.Open(cp & "\" & arch)
Set h2 = l2.Sheets(1)
u = h1.Range(col & Rows.Count).End(xlUp).Row + 1
h2.Range(rango).Copy
h1.Cells(u, col).PasteSpecial xlValues
h1.Cells(u, col).PasteSpecial xlFormats
h1.Range(h1.Cells(u, Columns(col).Column + ncol), _
h1.Cells(u + nrow, Columns(col).Column + ncol)) = l2.Name
l2.Close False
arch = Dir()
Loop
MsgBox "Fin"
End Subsal u dos
. 09.03.17 #VBA traer rango de Varios Archivos a uno consolidador
Buenas noches, Robert
A continuación te paso una rutina que deberías agregar a tu archivo que funciona como receptor del rango que le indiques de las hojas en los archivos que tienes en esa carpeta.
En ese archivo operativo, accede al Editor de VBA (Atajo: Alt + F11), inserta un módulo (Insertar -Módulo) y pega el siguiente código:
Sub Consolid() '---- Variables modificables ---- '=== ROBERT, modificá estos datos de acuerdo a tu proyecto: DirBusc = "C:\CarpetaDeArchivos" 'carpeta donde están los archivos Extension = "xls" 'Extensión de los archivos a consolidar. Dejar "*" para que sean todos TraerHoja = "HojaEnComun" 'Hoja de donde tomar los datos de cada archivo ElRango = "A2:B2" JuntarEn = "consolidado" 'Hoja de destino. Limpiar = "SI" ' SI para vacíar la hoja consolidado o NO para que agregue a lo existente. '---- fin Variables ' '---- inicio de rutina: ' Sheets(JuntarEn).Select If Limpiar = "SI" Then Cells.Clear DirBusc = DirBusc & IIf(Right(DirBusc, 1) = "\", "", "\") Set ArchConsol = ActiveWorkbook LosArchivos = Dir(DirBusc & "*." & Extension) Application.DisplayAlerts = False Application.ScreenUpdating = False Do While LosArchivos <> "" Donde = Application.WorksheetFunction.CountA(ArchConsol.Sheets(JuntarEn).Cells) Donde = IIf(Donde > 0, Cells(Sheets(JuntarEn).UsedRange.Row + Sheets(JuntarEn).UsedRange.Rows.Count + 1, Sheets(JuntarEn).UsedRange.Column).Address, "A1") Workbooks.Open DirBusc & LosArchivos, xlNo Sheets(TraerHoja).Visible = True Sheets(TraerHoja).Range(ElRango).Copy ArchConsol.Sheets(JuntarEn).Range(Donde).PasteSpecial Paste:=xlPasteValues ArchConsol.Sheets(JuntarEn).Range(Donde).PasteSpecial Paste:=xlPasteFormats ArchConsol.Sheets(JuntarEn).Range(Donde).End(xlToRight).Offset(0, 1).Value = LosArchivos Workbooks(LosArchivos).Close xlNo cont = cont + 1 LosArchivos = Dir Loop Application.ScreenUpdating = True Application.DisplayAlerts = True ElMensaje = IIf(cont = 0, "NO SE AGREGO DATOS DE NINGUN ARCHIVO", "Se agregaron DATOS de : " & cont & " archivo" & IIf(cont > 1, "s", "")) TipoMens = IIf(cont = 0, vbCritical, vbInformation) ElTitulo = IIf(cont = 0, "NO SE HIZO NADA", "TERMINADO!") Application.ScreenUpdating = True MsgBox ElMensaje, TipoMens, ElTitulo Set ArchConsol = Nothing Application.StatusBar = False End Sub
Nota que al principio del código le podrás indicar de qué carpeta leer los archivos y cual es la extensión que deseas considerar.
También están indicadas la hoja de destino y la de origen de cada archivo (no importa si estuviere oculta o no) y qué rango traer.
A falta de aclaración dejé una última variable que si dejas en SI, borrará todo lo que tiene la hoja de consolidación para empezar de nuevo. Si colocas NO, dejará los datos que tuviese al ejecutar la rutina.
El procedimiento se encarga de agregar a la hoja consolidación el contenido del rango de la hoja indicada de cada archivo que abra -como valores y con el formato original- así como el nombre del archivo a la derecha del último dato traido. Luego cierra el archivo que abrió, sin cambios, para pasar al siguiente.
Pruebalo con tu caso real -y, si te sirviera, agradeceré que califiques mi contribución- o escribeme de nuevo aquí, si necesitas más apoyo con esto.
Un abrazo
Fernando
.
buenos días.!
Las disculpas respectivas, por el no haber respondido antes, por problemas técnicos con el computador.
Pero ya volviendo e iniciando la macros compartida por su persona, déjeme decirle, que si me sirvió muchísimo y agradezco el tiempo que se tomo para responderla.
Gracias..!
Éxitos en todo.!
No cabe duda que en esta pagina si apoyan.......Saludos para tod@s...
Pregunta respondida con éxito..!
.
Todo bien, Robert
Lo importante es que tengas resuelto el problema lo antes posible.
Abrazo
Fer
.
¡Gracias!
De verdad muchísimas gracias...!!!
espero me puedas ayudar con una duda personal con respecto a otra pregunta, espero no ser tan molesto
saludos
.
¡Cuando gustes!
¿Tiene qué ver con esta misma pregunta?
Un saludo
Fer
.
¡Gracias! Buenos días mi estimado amigo Fer.
Resulta que tengo una duda con este otro tema.
Una macros que me de el historial de los cambios que se dieron en todo un archivo excel, de Nhojas
te agradecería mucho si al menos se hiciera algo que se asemeje a mi pregunta, para obtener los resultados descritos, incluyendo fechas.
saludos..!