# Macro para extraer informacion de varias hojas y consolidarlas en un nuevo libro



## JORGEMELS (Apr 26, 2014)

Hola, estoy iniciandome en esto pero no encuentro sintaxis en ningun lado espero pueda encontrar ayuda aqui, tengo un libro con varias hojas de calculo A1, A2, A3, A4, y tengo informacion en tablas de cada una y necesito un macro para poder seleccionar el rango de ellas y consolidar la informacion en otro archivo, es decir que el macro diga :

Ingresar rango deseado de hojas

yo pondria por ejemplo de A31 a A34

y que me consolide en una nueva hoja de calculo llamada consolidado

Ejemplo:

ejemplo - YouTube


----------



## JORGEMELS (Apr 26, 2014)

bump


----------



## fhaider (Apr 26, 2014)

Utiliza esta macro para resolver el problema que usd tiene.

Lo siento para mal esponal como ya aprendiendo esta lengua.


```
Sub CopiarPegarTablas()

    Dim n As Worksheet
    Dim curWB, newWB As Workbook
    
    curWB = ThisWorkbook.Name
    
    Workbooks.Add
    newWB = ThisWorkbook.Name
    
    curWB.Activate

    For Each n In Worksheets ' Loop para selectionar varias hojas
        n.Select
        If Application.WorksheetFunction.CountA(Range("C:C")) > 1 Then ' condicion para prueba si datos existan en tablas
            Range("B11:I" & Range("I65536").End(xlUp).Row).Copy
            newWB.Activate
            Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
            curWB.Activate
        End If
    Next n

End Sub
```


----------



## JORGEMELS (Apr 26, 2014)

muchas greaacias por tu ayuda, no puedo echarlo a andar

imgur: the simple image sharer

este es el archivo:

https://skydrive.live.com/redir?page=view&resid=417FFA752E92993C!1031&authkey=!AI0wy5vEcaWT0Ns


----------



## fhaider (Apr 26, 2014)

prueba esta code...

esta macro no va a funcionar para hidden hojas


```
Sub CopiarPegarTablas()

    Dim n As Integer
    Dim curWB As String
    Dim newWB As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    curWB = ThisWorkbook.Name
    
    Workbooks.Add
    newWB = ActiveWorkbook.Name
    
    Workbooks(curWB).Activate

    For n = 31 To 34 ' Loop para selectionar varias hojas * cambio para diferente numero del hojas
        Sheets("A" & n).Select
        If Application.WorksheetFunction.CountA(Range("C:C")) > 1 Then ' condicion para prueba si datos existan en tablas
            Range("C11:I" & Range("I65536").End(xlUp).Row).Copy
            Workbooks(newWB).Activate
            Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Workbooks(curWB).Activate
        End If
    Next n

    Workbooks(newWB).Activate
    Range("A1:A" & Range("A65536").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=""
    Range("A3:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
    Selection.Rows.Delete
    ActiveSheet.AutoFilterMode = False
    
    Columns("B:B").NumberFormat = "m/d/yyyy h:mm"

End Sub
```


----------



## JORGEMELS (Apr 26, 2014)

Muchisimas gracias fhaider, este funciono excelente, ya le estoy haciendo ajustes, no crei que me fueran a ayudar tan rapido.


----------



## JORGEMELS (Apr 26, 2014)

asi es como funciona cierto?


```
Sub CopiarPegarTablas()

    Dim n As Integer
    Dim curWB As String
    Dim newWB As String
    
    Application.ScreenUpdating = False ' comando para evitar que se actualice la informacion?
    Application.DisplayAlerts = False ' coomando para evitar que se mande un error?
    
    curWB = ThisWorkbook.Name
    
    Workbooks.Add ' agregar libro
    newWB = ActiveWorkbook.Name
    
    Workbooks(curWB).Activate ' activar current workbook


    For n = 34 To 36 ' Loop para selectionar varias hojas * cambio para diferente numero del hojas
        Sheets("A" & n).Select
        If Application.WorksheetFunction.CountA(Range("C:C")) > 1 Then ' condicion para prueba si datos existan en tablas
            Range("C11:I" & Range("I65536").End(xlUp).Row).Copy ' seleccionar el rango deseado siempre y cuando existan datos
            Workbooks(newWB).Activate
            Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Workbooks(curWB).Activate
        End If
    Next n


    Workbooks(newWB).Activate
    Range("A1:A" & Range("A65536").End(xlUp).Row).AutoFilter Field:=1, Criteria1:="" ' pegar datos en la hoja y dejar la primera fila en blanco
    Range("A3:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select ' quitar blancos
    Selection.Rows.Delete
    ActiveSheet.AutoFilterMode = False
    
    Columns("B:B").NumberFormat = "m/d/yyyy h:mm"


End Sub
```


----------



## fhaider (Apr 27, 2014)

De nada!

La primera fila es blanco porque esta code.  La foncionar de "Offset(1,0)" causa primera fila ser blancos


```
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
```

Tambien...

```
Range("A1:A" & Range("A65536").End(xlUp).Row).AutoFilter Field:=1, Criteria1:="" ' esta code pone "Filter" en la tabla y mostra filas entre diferent varias tablas que estan blancos
Range("A3:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select ' selecionando filas/cildas que esta visible y blanco
Selection.Rows.Delete ' quitar blancos
```


----------

