Macro para eliminar las filas a partir de la 4 que no coincidan con el texto de la celda ah1. (buscar dentro de la columna ah)

"para Dante Amor"

Macro para eliminar las filas a partir de la 4 que no coincidan con el texto de la celda ah1. (Buscar dentro de la columna ah).

Me parece que unos de los problemas que la macro se hace lenta es porque tengo muchos datos duplicados.

Dejo la macro que tengo y adjunto el link del archivo.

https://www.dropbox.com/s/kvzgihwzrcylmc0/ah1-clientes.xlsm?dl=0 

Sub Eliminar_Diferentes2()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
    dato = Range("AH1")
    If dato = "" Then
        MsgBox "Ingresa un dato en AH1"
        Exit Sub
    End If
    '
    For i = 2000 To 4 Step -1
        If Cells(i, "AH") <> dato Then Rows(i).Delete
    Next
    MsgBox "Fin"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    ActiveSheet.DisplayPageBreaks = True
    Application.CutCopyMode = False
End Sub

1 Respuesta

Respuesta
2

Envíame tu archivo para revisarlo, como te comenté, hice una prueba con 6000 registros y la respuesta es de 2 segundos

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “pablo ninguno” y el título de esta pregunta.

¡Gracias! Dante ya pude solucionarlo, igualmente muchas gracias por tu ayuda.

Dejo el código por si le sirve a alguien más.

Saludos

Sub QuitaFilas()
    Dim uf&, i&, a, R As Range
    Application.ScreenUpdating = False
    uf = Range("AH" & Rows.Count).End(xlUp).Row
    a = Range("AH1:AH" & uf)
    For i = 4 To UBound(a)
        If a(i, 1) <> Range("AH1") Then
            If R Is Nothing Then
                Set R = Range("AH" & i)
            Else
                Set R = Union(R, Range("AH" & i))
            End If
        End If
    Next i
    R.EntireRow.Delete
    Set R = Nothing: Erase a
    Range("AH4").Select
    Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas