Macro que elimine registros duplicados
Solicito una macro que elimine registros repetidos de una base de datos, donde los registros están colocados u ordenados en columnas por nombre, teléfono, dirección, email, etc, quiero que antes que los elimine, los ponga de un color y me dé la opción de que si quiero eliminarlos.
Pero si dentro de esos registros, por ejemplo un email, esté repetido pero el nombre y los demás datos son diferentes, que se le resalte de otro color, ¿se podría hacerlo así?
1 Respuesta
H o la : Te anexo la macro.
IMPORTANTE! Antes de ejecutar la macro debes seguir las siguientes indicaciones:
- Cambia en la macro "datos" por el nombre de tu hoja.
- Cambia "D" por la letra de la columna donde tienes los correos
- Tus encabezados deberá empezar en la fila 1 y en la columna "A". Los datos empezarán desde la fila 2.
- Crea una hoja con el nombre de "temp"
Ejecuta la macro RevisarDuplicados. La macro te preguntará si quieres eliminar los duplicados, si respondes "Sí", la macro elimina los registros que estén duplicados, es decir, si todos los datos desde la columna A hasta la última columna con datos, son iguales todos los datos, entonces elimina el registro duplicado y te deja solamente un registro.
Si respondes "No", la macro solamente te marcará de amarillo los registros duplicados.
También, la macro te marcará de color verde los correos que estén duplicados, pero que alguno de los otros datos sea diferente.
Sub RevisarDuplicados()
'Por.Dante Amor
Set h1 = Sheets("datos") 'Nombre de la hoja con datos
Set h2 = Sheets("temp")
col = "D" 'Columna de email
ncol = Columns(col).Column
'
h1.Cells.Interior.ColorIndex = xlNone
h2.Cells.Clear
uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column
ini = h1.Name & "!RC"
cad = "=" & ini & "&"
'
For k = 1 To uc - 1
cad = cad & ini & "[" & k & "]&"
Next
If Right(cad, 1) = "&" Then cad = Left(cad, Len(cad) - 1)
uf = h1.Range("A" & Rows.Count).End(xlUp).Row
'Contar registros duplicados
With h2.Range("A1:A" & uf)
.FormulaR1C1 = cad
.Value = .Value
End With
With h2.Range("B1:B" & uf)
.FormulaR1C1 = "=COUNTIF(R1C1:R" & uf & "C1,RC[-1])"
.Value = .Value
End With
With h2.Range("C1:C" & uf)
.FormulaR1C1 = "=COUNTIF(RC[-2]:R" & uf & "C1,RC[-2])"
.Value = .Value
End With
'Contar correos duplicados
Call CorreoDuplicado(h1, h2, uf, col, ncol)
'
borrar = MsgBox("Deseas Borrar", vbYesNo + vbQuestion, "DUPLICADOS")
If borrar = vbYes Then
For i = uf To 2 Step -1
If h2.Cells(i, "C") > 1 Then
h1.Rows(i).Delete
End If
Next
h1.Cells.Interior.ColorIndex = xlNone
uf = h1.Range("A" & Rows.Count).End(xlUp).Row
Call CorreoDuplicado(h1, h2, uf, col, ncol)
MsgBox "Registros borrados"
Else
For i = uf To 2 Step -1
If h2.Cells(i, "B") > 1 Then
h1.Range(h1.Cells(i, "A"), h1.Cells(i, uc)).Interior.ColorIndex = 6
End If
Next
MsgBox "Registros Marcados"
End If
End Sub
'
Sub CorreoDuplicado(h1, h2, uf, col, ncol)
'Por.Dante Amor
With h2.Range("D1:D" & uf)
.FormulaR1C1 = "=datos!RC" & ncol
.Value = .Value
End With
With h2.Range("E1:E" & uf)
.FormulaR1C1 = "=COUNTIF(R1C4:R" & uf & "C4,RC[-1])"
.Value = .Value
End With
For i = uf To 2 Step -1
If h2.Cells(i, "E") > 1 Then
h1.Cells(i, col).Interior.ColorIndex = 4
End If
Next
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
