Saltar al contenido
Te enseño 7 de los trucos que me permitieron trabajar 2 horas menos al día >>>

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

luis ayala

Recommended Posts

luis ayala Novato

luis ayala

publicado
publicado

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 Novato

joshua

publicado
publicado

Saludos.

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

Atte.

joshua

joshua Novato

joshua

publicado
publicado

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 Novato

Armando Montes

publicado
publicado

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 Novato

luis ayala

publicado
  • Autor
publicado

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 Novato

joshua

publicado
publicado

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 Novato

Armando Montes

publicado
publicado

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 Novato

luis ayala

publicado
  • Autor
publicado

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?

luis ayala Novato

luis ayala

publicado
  • Autor
publicado

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

luis ayala Novato

luis ayala

publicado
  • Autor
publicado

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

joshua Novato

joshua

publicado
publicado

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

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • Sí
      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Mantenimiento de la comunidad
      Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR

  • Archivos

  • Estadísticas de descargas

    • Archivos
      187
    • Comentarios
      97
    • Revisiones
      29
    Más información sobre "Un juego del Rabino en Excel"
    Última descarga
    Un juego del Rabino en Excel
    Por pegones1

    2    1

  • Crear macros Excel

  • Mensajes

    • Tilin2023
      FORMULA MACRO PARA QUE LA FORMULA SIEMPRE TOME LA ULTIMA FILA Y COLUMNA DE UNA TABLA A PESAR QUE AUMENTE

      Por Tilin2023 · publicado

      Adjunto excel CONTADOR FINAL.xlsb
    • Tilin2023
      FORMULA MACRO PARA QUE LA FORMULA SIEMPRE TOME LA ULTIMA FILA Y COLUMNA DE UNA TABLA A PESAR QUE AUMENTE

      Por Tilin2023 · publicado

      Buenos días,  espero se encuentren bien de salud compañeros, Favor me podrían ayuda con lo siguientes como se podría hacer cuando tengo una tabla dinámica que  amedida que se aumente las columnas fechas con data un formula que se coloco al final busque o analice siempre la ultima fila y columna de la fecha. Coloco un ejemplo
    • Tilin2023
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por Tilin2023 · publicado

      @JSDJSD Excelentes, GRACIAS POR TU SOPORTE , me ayudo demasiado es exactamente lo que quería. 5 ESTRELLAS
    • JSDJSD
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por JSDJSD · publicado

      'Opción 1 Sub FiltrarSKUPorFecha(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim diccionarioSKU As Object Dim listaEliminar As Object Dim fechaActual As String, fechaSiguiente As String Dim f As Variant With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Crear diccionarios para comparar SKU y almacenar filas a eliminar Set diccionarioSKU = CreateObject("Scripting.Dictionary") Set listaEliminar = CreateObject("Scripting.Dictionary") ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then diccionarioSKU.RemoveAll ' Limpiar el diccionario antes de llenarlo ' Guardar los SKU de la fecha siguiente (solo de la siguiente) For f = fila + 1 To ultimaFila If .Cells(f, 1).Value <> fechaSiguiente Then Exit For diccionarioSKU(.Cells(f, 2).Value) = 1 Next f ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Solo eliminar si el SKU no está en la fecha siguiente If Not diccionarioSKU.exists(.Cells(f, 2).Value) Then listaEliminar(f) = 1 ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar.keys .Rows(f).Delete Next End With MsgBox "Completado correctamente.", vbInformation End Sub 'Opción 2 Sub FiltrarSKUPorFecha1(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim listaEliminar As Collection Dim fechaActual As String, fechaSiguiente As String Dim f As Variant, i As Long Dim SKUExiste As Boolean With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Inicializar la colección para marcar las filas a eliminar Set listaEliminar = New Collection ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Comprobar si el SKU está en la fecha siguiente SKUExiste = False For i = fila + 1 To ultimaFila If .Cells(i, 1).Value <> fechaSiguiente Then Exit For If .Cells(i, 2).Value = .Cells(f, 2).Value Then SKUExiste = True Exit For End If Next i ' Si el SKU no se encuentra en la fecha siguiente, marcar para eliminar If Not SKUExiste Then listaEliminar.Add f ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar .Rows(f).Delete Next f End With MsgBox "Completado correctamente.", vbInformation End Sub   TABLA ELIMINAR.xlsm
    • JSDJSD
      COMO ELIMINAR FILAS CON FECHA QUE NO APARECEN AL SIGUIENTE DIA

      Por JSDJSD · publicado

      Prueba y comenta 

  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.