Macro para unificar libros en un solo libro, dividiendolo por hojas.

[ndbonino]

Hola a todos!

Quería saber si me pueden ayudar con este problema. El problema surge porque tengo 133 archivos de excel, y me gustaría poder copiarlos a todos en un solo excel, dividiendo la información de cada archivo en una hoja, y respetando el orden de numeracion, es decir, la información del archivo llamado 1, se coloque en la hoja 1, la del archivo dos, en hoja 2, y así sucesivamente. 

He encontrado Macros que realizan este trabajo, pero copian toda la información en una sola hoja, y el recorrido de Archivos es aleatorio, por lo que me modifica el orden necesario de los mismos. 

 

Un saludo y ojalá puedan ayudarme. 

[Antoni]

Sube uno de los archivos.

[ndbonino]

Adjunto un archivo y la macro que encontré:

Option Explicit
Dim nArchivo As Integer, Conteo As Integer, i As Integer, j As Integer, n As Integer
Sub ImportarData()

Call ContarArchivos
   
Application.ScreenUpdating = False
Dim WorkBookOrigen As Workbook
    Dim wsOrigen As Excel.Worksheet, _
    wsDestino As Excel.Worksheet, _
    rngOrigen As Excel.Range, _
    rngDestino As Excel.Range, _
    NombreArchivo As String, _
    Carpeta As String
    
    Carpeta = ActiveWorkbook.Path & "\"

nArchivo = 1

NombreArchivo = Dir(Carpeta & "LibroO" & "*.xl*")

Do While Len(NombreArchivo) > 0
    

        Set WorkBookOrigen = Workbooks.Open(Carpeta & NombreArchivo)
            
            NombreArchivo = Dir()
            
        ThisWorkbook.Activate
            
        Set wsOrigen = WorkBookOrigen.Worksheets(1)
        Set wsDestino = Worksheets(1)
        
        Const celdaOrigen = "A1"
        
        Set rngOrigen = wsOrigen.Range(celdaOrigen)
        
        wsOrigen.Activate
        rngOrigen.Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
        
Errores:
        If Err.Number = 1004 Then
            wsOrigen.Activate
            rngOrigen.Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
        End If
        
            For n = 1 To 1
            wsDestino.Activate

On Error GoTo Errores

                wsDestino.Cells(Columns.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Next n
            Application.CutCopyMode = False
        
        WorkBookOrigen.Save
        WorkBookOrigen.Close
        
        nArchivo = nArchivo + 1
        
    Call Progreso
                    

Loop

j = nArchivo - 1

Application.ScreenUpdating = True

MsgBox j & " Archivos procesados"

End Sub
Public Sub Progreso()
Dim Contador As Integer
Dim Maximo As Integer
Dim Mitiempo As Double

Maximo = nArchivo - 1
 
For Contador = 1 To Maximo Step 1
    Mitiempo = Timer
    Do
        Loop While Timer - Mitiempo < 0.02
        Application.StatusBar = "Progreso: " & Maximo & _
        " de " & i & " (" & Format(Maximo / i, "Percent") & ")"
    DoEvents
Next Contador
 
Application.StatusBar = False
End Sub
Public Sub ContarArchivos()
Dim cNombreArchivo, cCarpeta As String

cCarpeta = ActiveWorkbook.Path & "\"

Conteo = 1

cNombreArchivo = Dir(cCarpeta & "LibroO" & "*.xl*")

Do While Len(cNombreArchivo) > 0
    cNombreArchivo = Dir()
    Conteo = Conteo + 1
Loop

i = Conteo - 1
End Sub
 

 

499.xls

[JSDJSD]

Prueba y comenta

Unir libros.xlsm

[ndbonino]

Hola!

Lo he probado y funciona a la perfección!

Muchísimas gracias por tu tiempo,

Un saludo!

[JSDJSD]

Me alegro pero no olvides agradecer a quien te ayuda o intenta ayudar y en el foro es mediante el corazoncillo que tenemos en la parte inferior derecha.

[ndbonino]

Perfecto, soy nuevo, de hecho llevo 3 días en el foro, así que me voy acostumbrando a cómo agradecer y demás. 

Un saludo grande, y muchas gracias a los dos!

[JSDJSD]

Seguro que el Maestro Antoni te tiene preparado algo que seguro te sorprende

[ndbonino]

Yo pedí demasiado detalle, el que lo separe por hoja ya es por gusto, el que esté todo presente en una hoja ya me facilita mucho el análisis. 

Veremos cómo nos sorprende!

Un gusto y nos vemos por el foro!

[ndbonino]

Hace 16 horas, JSDJSD dijo:

Prueba y comenta

Unir libros.xlsm 22.64 kB · 3 descargas

Hola de nuevo, disculpa que te moleste.

Te quería consultar si esa macro se puede modificar para que nunca copie la fila 1, y que no inserte un espacio cada vez que pega el contenido en la hoja agrupación.

Según mis básicos conocimientos de VB esto se modificaría en la parte siguiente, pero no estoy seguro como realizarlo:

For y = LBound(X) To UBound(X)
            Application.StatusBar = "Importando Archivos: " & X(y)
            Workbooks.Open X(y)
            b = ActiveWorkbook.Name
            For Each Hoja In ActiveWorkbook.Sheets
                Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
            Next

El motivo de esta modificación es para luego poderle dar formato de tabla y trabajar con los datos más ordenados.

Muchas gracias!

[JSDJSD]

Prueba y comenta

Unir libros.xlsm

[ndbonino]

Hace 12 minutos , JSDJSD dijo:

Prueba y comenta

Unir libros.xlsm 22.9 kB · 0 descargas

Perfecto! Funcionó como quería!

[migtons01]

Hola, antes que nada muchas gracias por tu aporte, mi pregunta es si es solo para 

archivos con terminación .xls.

 

Gracias.

[JSDJSD]

Se puede modificar para que admita más terminaciones

[Caoru Aza]

Hola. Soy nueva, acabo de registrarme ya que me interesa el archivo "Unir Libros" que compartiste pero no me deja verlo. Me puedes ayudar? Gracias

[JSDJSD]

Hola Caoru Aza ponte en contacto con Sergio (Administrador de foro) el te explicará que tienes que hacer para poder descargar archivos del foro  y para cualquier consulta por aquí andamos.

[Caoru Aza]

Gracias?