Copiar varias lineas de cada pestaña (en diferentes renglones y rangos)en una hoja resumen nueva

[luis ayala]

Hola ,

Quisiera hacer una macro que copie lineas de cada pestaña en una resumen (nueva), claro es que en cada pestaña las lineas estan en diferente renglon, no cambian las columnas, solo la ubicacion de cada renglon inicial, y al pegarse se vayan colocando en la pestaña resumen (creada) .

Ya he tratado , pero cada pestaña tiene diferente tamaño de numero de lineas a pegarse y no todas estan en el mismo renglon inicial.

En cada pestaña se enlistan los titulos, son 2 titulos que se repiten (osea dos reportes), pero si nos basamos en la la celda A6 el titulo "Num. Recibo" es el titulo del primer listado de lineas, pero busco que copie las lineas que siguen del segundo titulo "Num. Recibo" en la misma columna A y los pegue en una Hoja nueva como resumen.

Espero me puedan ayudar.

ejemplo para macro.xls

[joshua]

Saludos.

Podrias ser mas grafico con el resultado que quieres obtener, es decir una hoja mostrando como es que quieres los datos.

Atte.

joshua

[luis ayala]

Hola Joshua. te anexo el resultado en una hoja adicional "RESUMEN", obvio esto es un ejemplo con solo 2 pestañas, pero mi archivo es de mas de 120 pestañas y quiero resumirlas en esa pestaña "RESUMEN"

ejemplo para macro.xls

[joshua]

Saludos.

Prueba con la siguiente macro, ojo que la hoja RESUMEN debe de estar al final de las pestañas.

Sub prueba()
For i = 1 To Worksheets.Count - 1
    hoja = Sheets(i).Name
    With Sheets(hoja)
        fh = .Range("A65536").End(xlUp).Row
        If Sheets("RESUMEN").Range("A6") = "" Then
            fr = 6
        Else
            fr = Sheets("RESUMEN").Range("A65536").End(xlUp).Row
        End If
        .Range("A6:M" & fh).Copy _
        Destination:=Sheets("RESUMEN").Range("A" & fr)
    End With
Next i
End Sub
[/HTML]

Atte.

joshua

[Armando Montes]

Hola Luis, la columna J esta vacia, eliminandola copiara todo, si necesitas esa columna ajustare este codigo:

Sub RESUMEN()

Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

    ws.Activate

    With ActiveSheet.UsedRange

        .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")

        .Replace "", "x999x"

        .Replace "x999x", ""

    End With

        If ws.Name <> "RESUMEN" Then ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion _

            .Copy Sheet1.Range("A" & Rows.Count).End(xlUp).Offset(1)

    Next ws

Application.ScreenUpdating = True

End Sub[/CODE]

[luis ayala]

Estimado Armando ,

Gracias por tu macro , ya probe la macro que me sugieres y esta excelenete solo veo que si falta eliminar esa columna , ya que debe copiar hasta la columna "m" y con esta macro solo copia hasta la columna "i".

Te agradezco tu apoyo! La puedes ajustar y ponerla corregida?

De igual manera Joshua, soloq eu tu macro copia los dos reportes de cada pestaña y yo solo necesito copie el segundo reporte.

[joshua]

Saludos.

Prueba y comenta.

Sub prueba()
Sheets("RESUMEN").Cells.Clear
For i = 1 To Worksheets.Count
    hoja = Sheets(i).Name
    With Sheets(hoja)
        uc = Sheets("RESUMEN").Range("A65536").End(xlUp).Row + 1
        cf = .Range("A65536").End(xlUp).Row
        ci = .Range("A" & cf).End(xlUp).Row
        If Sheets(hoja).Name <> "RESUMEN" Then _
        .Range("A" & ci & ":M" & cf).Copy _
        Destination:=Sheets("RESUMEN").Range("A" & uc)
    End With
Next i

With Sheets("RESUMEN")
For columna = 1 To 13
        clvacia = Application.WorksheetFunction.CountA(.Cells(1, columna).EntireColumn)
        If clvacia = 0 Then _
        .Columns(columna).EntireColumn.Delete
Next columna
End With
End Sub
[/HTML]

Atte.

joshua

[Armando Montes]

Luis, aqui va como pediste, -en rojo- aunque la columna J aparece vacia:

Sub RESUMEN()

Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

    ws.Activate

    With ActiveSheet.UsedRange

        .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")

        .Replace "", "x999x"

        .Replace "x999x", ""

    End With

        If ws.Name <> "RESUMEN" Then ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion. _

        Resize(, 13).Copy Sheet1.Range("A" & Rows.Count).End(xlUp).Offset(1)

    Next ws

    Sheet1.[A2:M46].Columns.AutoFit

Application.ScreenUpdating = True

End Sub[/CODE]

Si las hojas originales estuvieran "limpias" de caracteres invisible podria eliminares desde ws.Activate hasta End With.

No salio el rojo marcando Resize(, 13).

[luis ayala]

GRacias por su pronta respuesta , revisando ambas macros , funcionan muy bien , y es verdad la columna "J" se puede eliminar.

Un gran favor , solo me falta lo siguiente:

Que el reporte comienze en la celda A6, ya que le pondre unos titulos y resumenes con otra macro,

Y poder ponerle esta restriccion, hay hojas que no quiero las copie en la pestaña RESUMEN.

La restriccion yo se la puse asi y me funciono con otras macros (sh =Worsheet):

For Each sh In ActiveWorkbook.Worksheets

'If sh.Name <> ("MENU") Then

If IsError(Application.Match(sh.Name, _

Array("MENU", "RESUMEN"), 0)) Then

Se puede integrar a sus formulas?

[Armando Montes]

Si eliminas la columna J no necesitas la modificacion que te di.

La major forma de comprobar es probandolo, te servira de practica.

Recomiendo la lectura de este manual:

http://profearias.files.wordpress.com/2011/09/manual_modulo_macros.pdf

[luis ayala]

Gracias armando lo leere,

Ya pude corregir lo de las pestañas que no pegue , pero viendo sus formulas, no hayo como poner que al pegar la informacion la ponga como texto , ya que esas columnas contienen formulas y al copiarse , se mueven los datos por ser formulas en las columnas K, L y M.

ejemplo de formula de Joshua

Destination:=Sheets("RESUMEN").Range("A" & uc)

Con esto pega tal cual , y no se como ponerlo en texto.

Espero mep uedan ayudar y con esto dar por solucionado el tema.

Slds

[Armando Montes]

Usa pegado especial/valores

Tal vea te facilite copiando todo y despues borrar J, no lo probe.

[luis ayala]

Hola Armando ya trate pero no hayo como meterlo en sus formulas.

[Armando Montes]

Hola Luis, es codigo VBA, no formulas.

Ejemplo encontrado con el buscador del foro:

Solucionado - Macro para pegado especial | Ayuda Excel

[luis ayala]

Hola Armando al correr tu formula en mi archivo de 120 pestañas vi que no corre, me marca un error siguiente

"Method 'range of object' _Worksheet' failed y marca en amarillo lo siguiente:

ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion. _

Resize(, 13).Copy Sheet1.Range("A" & Rows.Count).End(xlUp).Offset(1)

La formula es la siguiente, y mira que lo probe primero en el archivo que les mande y funciona bien, pero al correrlo en el grande esto me marca, yo le cambie la tercera linea , cambie "ThisWorkbook.Worksheets" a "ActiveWorkbook.Worksheets" le afectara?

Sub RESUMEN()

Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets

ws.Activate

With ActiveSheet.UsedRange

.Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")

.Replace "", "x999x"

.Replace "x999x", ""

End With

If ws.Name <> "RESUMEN" Then ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion. _

Resize(, 13).Copy Sheet1.Range("A" & Rows.Count).End(xlUp).Offset(1)

Next ws

Sheet1.[A2:M46].Columns.AutoFit

Application.ScreenUpdating = True

End Sub

[Armando Montes]

Solo viendo el libro donde colocaste el codigo, 2-3 hojas bastaran.

Por favor usa etiquetas para los codigos que publiques, en las normas del foro puedes ver como se hace, gracias.

[joshua]

Saludos.

Prueba la siguiente macro pegando solo valores en las columnas mencionadas.

Sub prueba()
Sheets("RESUMEN").Cells.Clear
For i = 1 To Worksheets.Count
    hoja = Sheets(i).Name
    With Sheets(hoja)
        uc = Sheets("RESUMEN").Range("A65536").End(xlUp).Row + 1
        cf = .Range("A65536").End(xlUp).Row
        ci = .Range("A" & cf).End(xlUp).Row
        If Sheets(hoja).Name <> "RESUMEN" Then _
        .Range("A" & ci & ":j" & cf).Copy _
        Destination:=Sheets("RESUMEN").Range("A" & uc): _
        .Range("K" & ci & ":M" & cf).Copy: _
        Sheets("RESUMEN").Range("K" & uc).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End With
Next i

With Sheets("RESUMEN")
For columna = 1 To 13
        clvacia = Application.WorksheetFunction.CountA(.Cells(1, columna).EntireColumn)
        If clvacia = 0 Then _
        .Columns(columna).EntireColumn.Delete
Next columna
End With
End Sub

[/HTML]

Prueba y comentas.

Atte.

joshua

[luis ayala]

Gracias joshua, ya la probe y funciona perfectamente, con esto doy por cerrado el tema y mi duda Resuelta

Saludos a todos!

[luis ayala]

TEMA FINALIZADO