Transferir información del libro 1 al libro2, en bloque.
Tengo una macro que me transfiere la información de un libro a otro, ambos libros son iguales en su estructura, rangos.
La macro transfiere la información del libro1 (origen) y la pega en el mismo rango en el libro2 (destino)
Sub CopiarDatos()
Dim Origen As Workbook, Destino As Workbook
Dim NombreOrigen As String, NombreDestino As String
Dim Hoja As String, Activa As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'--
NombreOrigen = [B1]
NombreDestino = [B2]
Set Activa = ActiveSheet
Set Origen = Workbooks.Open(NombreOrigen)
Set Destino = Workbooks.Open(NombreDestino)
For x = 4 To Activa.Range("A" & Rows.Count).End(xlUp).Row
Hoja = Activa.Range("A" & x)
Origen.Sheets(Hoja).Unprotect Password:=Activa.Range("C" & x)
Origen.Sheets(Hoja).Cells.Copy
Destino.Sheets(Hoja).Unprotect Password:=Activa.Range("C" & x)
Destino.Sheets(Hoja).Range("A1").PasteSpecial xlPasteFormulas
Destino.Sheets(Hoja).Protect Password:=Activa.Range("C" & x)
Next
Origen.Close SaveChanges:=False
Destino.Close SaveChanges:=True
'--
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Subpara que funcione, me pide la ubicación del libro origen, y el libro destino, y lista todas las hojas del libro; todo funciona bien.
Lo que quisiera poder hacer, es que se haga lo mismo pero a varios archivos
La siguiente macro
Me permite elegir una carpeta para posteriormente listar todos los archivos en esa carpeta
¿Cómo pudiera hacer para que la primera macro se adapte, y haga sus funciones a todos los libros?
Quedando así:
(En este ejemplo tiene 10 archivos para copiar la información, pero los que necesito serian aproximadamente 150 archivos)
1 Respuesta
La macro que lista los archivos es la siguiente:
Sub Mostrar_Archivos(ruta)
'Sección 1: Declaración de variables y objetos
Dim fs, carpeta, archivo, subcarpeta As Object
Set fs = CreateObject("Scripting.FileSystemObject")
'Sección 2: Ajustes necesarios a ruta
If ruta = "" Then
Exit Sub
ElseIf Right(ruta, 1) <> "" Then
ruta = ruta & ""
End If
'Sección 3: Objeto Folder de la ruta indicada
On Error GoTo ErrHandler
Set carpeta = fs.GetFolder(ruta)
'Sección 4: Obtener archivos del objeto Folder
For Each archivo In carpeta.Files
ActiveCell.Value = ruta & archivo.Name
ActiveCell.Offset(1, 0).Select
Next
'Sección 5: Obtener subcarpetas del objeto Folder
For Each subcarpeta In carpeta.SubFolders
Mostrar_Archivos (subcarpeta)
Next
'Sección 6: Auto-ajustar columnas y salir
ActiveCell.EntireColumn.AutoFit
Exit Sub
ErrHandler:
ActiveCell.Value = "Ruta inexistente"
End Sublo borre sin querer.
