Macro para selección múltiples de archivos y pegado en uno nuevo
Hola, tengo múltiples archivos de excel en una carpeta, y necesitaría consolidarlos todos en un único archivo (es decir copiar todo el contenido de esos archivos, a un único archivo) para después poder trabajarlos. El tema es que esos archivos no siempre tienen el mismo nombre, por lo que necesitaría poder seleccionarlos desde un menú.
Logré, a través de una de sus macros, hacer esto pero solo con un archivo, y sin seleccionarlo, sino que modificando el script de la macro, algo que no es para nada útil. Alguna idea? GRACIAS de antemano!!!
1 Respuesta
Hola DAM... Muchas gracias de antemano por la respuesta... Te cuento que encontré una solución a mi problema navegando por el foro, sin embargo me gustaría hacerte una consulta sobre el código...
Esto es lo que usé:
***
Private Sub CopiarDatos()
'Copia los datos en la hoja final
Dim strDir As String
Dim strHoja As String
Dim strFic As String
Dim strDest As String
Dim rngDest As Range
Dim rngDat As Range
Dim wbkAct As Workbook
Dim wbkDat As Workbook
Application.ScreenUpdating = False
Set wbkAct = ActiveWorkbook
strDir = wbkAct.Path
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
strHoja = "Actividades de Control"
'Nombre de la hoja destino donde se llevarán los datos
strDest = "Final"
strFic = Dir(strDir & "*.xls")
Do While strFic <> ""
'Fila de la hoja destino libre.
With wbkAct.Worksheets(strDest)
Set rngDest = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Abrir el fichero
If strFic <> wbkAct.Name Then
Set wbkDat = Workbooks.Open(strDir & strFic, 3)
With wbkDat.Worksheets(strHoja)
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 20)).Copy _
Destination:=rngDest
End With
wbkDat.Close False
End If
strFic = Dir
End With
Loop
Application.ScreenUpdating = True
End Sub
*****
Lo que me interesaría saber es si ademas de traerme los archivos con las extensiones *.xls, que pasa si quiero agregar los archivos *.xlsx también? se puede modificar el código para que también extraiga esa información.? O cómo había consultado al principio, se puede agregar la opción de elegirlos manualmente?
Y con respecto a tus preguntas, sí, están todos los libros dentro de un mismo directorio y solo me interesa exportar la primer hoja, denominada "Actividades de Control".
Gracias de nuevo..
Cambia esta línea
strFic = Dir(strDir & "*.xls")
por esta
strFic = Dir(strDir & "*.xls*")
Si quieres seleccionarlos manualmente uno o varios archivos, ocupa la siguiente macro
Private Sub CopiarDatos()
'Copia los datos en la hoja final
'Actualizado por.DAM
Dim strDir As String
Dim strHoja As String
Dim strFic As String
Dim strDest As String
Dim rngDest As Range
Dim rngDat As Range
Dim wbkAct As Workbook
Dim wbkDat As Workbook
Dim arch As Variant
Application.ScreenUpdating = False
Set wbkAct = ActiveWorkbook
strDir = wbkAct.Path
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
strHoja = "Actividades de Control"
'Nombre de la hoja destino donde se llevarán los datos
strDest = "Final"
strFic = Dir(strDir & "*.xls*")
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Selecciona uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos xls*", "*.xls*"
.Filters.Add "All Files", "*.*"
.FilterIndex = 1
.AllowMultiSelect = True
.InitialFileName = wbkAct.Path
If .Show Then
For Each arch In .SelectedItems
strFic = arch
'Fila de la hoja destino libre.
With wbkAct.Worksheets(strDest)
Set rngDest = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Abrir el fichero
If strFic <> wbkAct.Path & wbkAct.Name Then
Set wbkDat = Workbooks.Open(strFic, 3)
With wbkDat.Worksheets(strHoja)
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 20)).Copy _
Destination:=rngDest
End With
wbkDat.Close False
Set wbkDat = Nothing
End If
Set rngDest = Nothing
End With
Next
End If
End With
Set wbkAct = Nothing
Application.ScreenUpdating = True
End SubSaludos.DAM
Si es lo que necesitas.
