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 SubLastimosamente 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
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 SubS a l u d o s
