Macro que compile archivos en hojas distintas de un archivo base
Lo que necesito es ver la posibilidad de una macro que haga lo siguiente.
Que se encuentre en un archivo "Compilador", y que vaya abriendo todos los excel (uno por uno), copie la hoja 1 y la lleve al compilador generando una nueva hoja, la cual tendría el nombre del archivo abierto. Ejm.
Que Compilador abra la carpeta POR y en ella hay 3 archivos: Archivo 1, Archivo 2 y Archivo 3.
Se abre Archivo 1 y copia la Hoja 1 y crea una nueva hoja en Compilador con el nombre Archivo 1.
Se cierra Archivo 1, y continua con el Archivo 2, y así.
Te anexo la macro, selecciona la carpeta que contiene los archivos y la macro copiará la primer hoja de cada archivo.
Si la hoja ya existe en el archivo "compilador", le agregará un "-1" para hacer la diferente y poder renombrarla.
Sub Compilar_Hoja1() 'Por Dante Amor 'Compilar la primera hoja de los libros de una carpeta ' Application.ScreenUpdating = False 'Seleccionar la carpeta With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Selecciona una carpeta" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub carpeta = .SelectedItems(1) End With ' Set l1 = ThisWorkbook arch = Dir(carpeta & "\" & "*.xls*") Do While arch <> "" Set l2 = Workbooks.Open(carpeta & "\" & arch) l2.Sheets(1).Copy after:=l1.Sheets(l1.Sheets.Count) p = InStrRev(arch, ".") - 1 nombre = Left(Left(arch, p), 27) n_arch = nombre existe = False n = 1 Do While True existe = False For Each h In l1.Sheets If LCase(h.Name) = LCase(nombre) Then nombre = n_arch & "-" & n n = n + 1 existe = True Exit For End If Next If existe = False Then Exit Do Loop ActiveSheet.Name = nombre l2.Close False arch = Dir() Loop Application.ScreenUpdating = True MsgBox "Fin" End Sub
Prueba cargando 2 o 3 veces la misma carpeta.
.
.
