Duda con este codigo para eliminar registros repetidos

Hola tengo este codigo que elimina registros repetidos, si los elimina pero como tengo demasiados registros no me los respeta y borra registros demas.
Espero me puedas adyuar.
Este es el codigo.
Sub borrar_menos1()
Dim a() As String, rng As Range, str As String, i As Long, r As Range
Set rng = Range("C6", Range("C65536").End(xlUp))
start:
For Each r In rng
If Application.CountIf(Range("C6:C" & r.Row), r) > 1 Then
i = i + 1
ReDim Preserve a(1 To i)
a(i) = r.Address(0, 0)
If i = 50 Then
str = Join(C, ",")
Range(str).EntireRow.Delete
i = 0
Erase C
GoTo start
End If
End If
Next
str = Join(C, ",")
If str <> "" Then
Range(str).EntireRow.Delete
End If
Erase C
End Sub
Gracias.
Respuesta
1
Q+ Ricardots,
Prueba con este codigo:
Sub EliminarRepetidosYRegistro()
Dim Contador, Valor, Repetidos, Cuantos
Range("A2").Select
Range("A2:A29").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Contador = 1
Valor = ActiveCell.Value
ActiveCell.Offset(1, 0).Range("A1").Select
While ActiveCell.Value <> ""
If ActiveCell.Value = Valor Then
ActiveSheet.Next.Select
If ActiveCell.Value <> Valor Then
ActiveCell.Offset(1, 0).Range("a1").Select
ActiveCell.Value = Valor
End If
ActiveSheet.Previous.Select
Selection.Delete Shift:=xlUp
Contador = Contador + 1
Else
If Contador <> 1 Then
ActiveSheet.Next.Select
ActiveCell.Offset(0, 1).Range("a1").Select
ActiveCell.Value = Contador
ActiveCell.Offset(0, -1).Range("a1").Select
ActiveSheet.Previous.Select
End If
Contador = 1
Valor = ActiveCell.Value
ActiveCell.Offset(1, 0).Range("A1").Select
End If
Wend
If Contador <> 1 Then
ActiveSheet.Next.Select
ActiveCell.Offset(0, 1).Range("a1").Select
ActiveCell.Value = Contador
ActiveCell.Offset(0, -1).Range("a1").Select
ActiveSheet.Previous.Select
End If
Cuantos = Range("Cuantos")
Respuesta = MsgBox("Se han encontrado " & Cuantos & " elementos repetidos", 1, "Número de repetidos")
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas