Macro que busque un registro por su código y si hay varios registros con ese código, me dé la posibilidad de borrar los antiguos

Me ayudaste con la siguiente macro la cual busca los registros repetidos y borra los repetidos más antiguos para solo dejar los registros recientes para cada código.

Sub EliminarDuplicados()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("CLIENTES")
    u = h1.Range("C" & Rows.Count).End(xlUp).Row
    '
    With h1.Sort
     .SortFields.Clear: .SortFields.Add Key:=h1.Range("C2:C" & u)
                        .SortFields.Add Key:=h1.Range("A2:A" & u)
     .SetRange h1.Range("A1:T" & u): .Header = xlYes: .Apply
    End With
    '
    ant = ""
    For i = u To 2 Step -1
         If ant = h1.Cells(i, "C") Then
            h1.Rows(i).Delete
        End If
        ant = h1.Cells(i, "C")
    Next
    Application.ScreenUpdating = True
    MsgBox "Se eliminaron los duplicados", vbInformation
End Sub

Lastimosamente como tengo demasiados registros (5.000 y van en aumento cada dia) ejecuté la macro pero lleva ahora 10 minutos y aún no ha terminado y se bloqueó el excel. Entonces se me ocurrió otra idea para irlos actualizando solo dejando los mas recientes y es que cada vez que llame un registro, el busque en la base de datos de la hoja "Clientes" si para ese código hay mas registros repetidos, si encuentra que no, la macro no hace nada y termina, pero si encuentra que sí, sería excelente que me salga un msgbox diciendo lo siguiente "El presente código presenta registros repetidos, desea eliminar los mas antiguos y dejar el más reciente?" VbYesNo. Si doy si, elimina los registros repetidos antiguos para ese código y deja solo el más reciente. Si respondo No entonces termina la macro.

1 Respuesta

Respuesta
1

H o l a:

¿Y cómo vas a llamar un código? ¿Lo vas a poner en una celda?

H o l a:

¿Si en la hoja clientes hay 3 registros quieres que se borren los 3 registros?

¿O quieres que se borren 2 registros y dejar el más reciente?

Si hay 3 registros repetidos, que se borren los 2 más antiguos y dejar solo el más reciente.

¿No me dijiste cómo vas a poner el código?

Colocaría el código en la celda "C7" de la hoja "Visitas"

H o l a:

Te anexo la macro actualizada.

Sub BuscarCodigo()
'Por.Dante Amor
    Application.ScreenUpdating = False
    cod = Sheets("visitas").[C7]
    Set h1 = Sheets("CLIENTES")
    Set b = h1.Columns("C").Find(cod, LookAt:=xlWhole)
    If Not b Is Nothing Then
        res = MsgBox("El presente código presenta registros repetidos," & _
                     " desea eliminar los mas antiguos y dejar el más reciente?", _
                     vbQuestion & vbYesNo, "CLIENTES")
        If res = vbYes Then
            u = h1.Range("C" & Rows.Count).End(xlUp).Row
            With h1.Sort
             .SortFields.Clear: .SortFields.Add Key:=h1.Range("C2:C" & u)
                                .SortFields.Add Key:=h1.Range("A2:A" & u), Order:=xlDescending
             .SetRange h1.Range("A1:T" & u): .Header = xlYes: .Apply
            End With
            '
            Set r = h1.Columns("C")
            Set b = r.Find(cod, LookAt:=xlWhole)
            una = True
            If Not b Is Nothing Then
                ncell = b.Address
                Do
                    celda = b.Address
                    If una = False Then
                        Rows(b.Row).Delete
                        Set b = r.Find(cod, LookAt:=xlWhole)
                    End If
                    una = False
                    Set b = r.FindNext(b)
                Loop While Not b Is Nothing And b.Address <> ncell
            End If
        End If
    End If
End Sub

S a l u d o s

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas