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

[JORGEMELS]

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]

bump

 

[fhaider]

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]

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]

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]

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

 

[JORGEMELS]

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]

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