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

Saludos.

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

Atte.

joshua

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

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

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]

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.

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

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).

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?

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

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

Usa pegado especial/valores

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

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

Hola Luis, es codigo VBA, no formulas.

Ejemplo encontrado con el buscador del foro:

Solucionado - Macro para pegado especial | Ayuda Excel

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

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.

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

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

Saludos a todos!

TEMA FINALIZADO