Necesito corregir macro de extracción de datos

Tengo la siguiente macro:

Sub resumen()
Sheets("TOTAL TIENDAS"). Activate
Range("A1:K15000"). ClearContents
For x = 5 To 14
Sheets(x).Select
Range("a1:f" & Range("a65000").End(xlUp).Row).Copy
Sheets("TOTAL TIENDAS").Range("a65000").End(xlUp).Offset(0, 0).PasteSpecial Paste:=xlValues
Next
Sheets("TOTAL TIENDAS").Select
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
    x = WorksheetFunction.CountIf(Range("A:A"), ActiveCell)
    If x > 1 Then
        ActiveCell.EntireRow.Delete
    Else
        ActiveCell.Offset(1, 0).Select
    End If
Loop
Sheets("Portada").Select
End Sub

Mi problema es que la última fila de cada una de las hojas no me la copia, ¿qué es lo que tengo que cambiar para que me lo copie?

Respuesta
1

H o l a : La macro si está copiando la última línea, lo que pasa es que la información de la siguiente hoja está sobreescribiendo la última fila de la hoja anterior, es por eso que no la ves.


Cambia en tu macro esta línea

Sheets("TOTAL TIENDAS"). Range("a65000").End(xlUp).Offset(0, 0).PasteSpecial Paste:=xlValues

Por esta

Sheets("TOTAL TIENDAS"). Range("a65000").End(xlUp).Offset(1, 0). PasteSpecial Paste:=xlValues

Le hice unos ajustes a tu macro, quedaría así:

Sub resumen()
'Act.Por.Dante Amor
    Set h = Sheets("TOTAL TIENDAS")
    h.Cells.ClearContents
    For x = 5 To 6
        Sheets(x).Range("A1:F" & Sheets(x).Range("a65000").End(xlUp).Row).Copy
        h.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
    Next
    h.Rows(1).Delete
    Sheets("TOTAL TIENDAS").Select
    Range("A1").Select
    Do While Not IsEmpty(ActiveCell)
        x = WorksheetFunction.CountIf(Range("A:A"), ActiveCell)
        If x > 1 Then
            ActiveCell.EntireRow.Delete
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
    Sheets("Portada").Select
End Sub

Pero hay algo que no entiendo. Realmente no sé para que es la segunda parte:

    Sheets("TOTAL TIENDAS").Select
    Range("A1").Select
    Do While Not IsEmpty(ActiveCell)
        x = WorksheetFunction.CountIf(Range("A:A"), ActiveCell)
        If x > 1 Then
            ActiveCell.EntireRow.Delete
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop

Me imagino que quieres borrar duplicados o algo así. Pero en la forma que lo tienes no me funciona, pero si a ti te funciona, entonces ocupa la macro actualizada.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas