Tengo un problema que no puedo llegar a eliminar los duplicados dentro de la misma sección (el mismo nombre en la columna B). Se debe analizar cada sección y mantener sólo el primero valor único de cada sección.
El problema es que analiza si 2 filas consecutivas tienen el mismo nombre (que indica la sección), y en base a que elimina los duplicados. No analizar cada sección de comparación, por ejemplo, primera fila con la última fila, pero 1 por 1, lo cual es incorrecto, porque la penúltima o la última fila de cada sección pueden tener un duplicado sobre la base de la primera fila.
Estoy seguro de que se puede encontrar mejor y el código aquí más optimizado, éste hace el trabajo:
Sub DeleteDuplicates
Dim ColBrand As Integer, ColMil As Integer, ColColor as Integer
Dim RowSectionStart as Integer, RowCurrent as Integer
Dim ws As Worksheet
Set ws = Workbooks("Classeur1").Sheets("Feuil1")
ColBrand = 2
ColMil = 3
ColColor = 4
RowCurrent = 2
Do While ws.Cells(RowCurrent, ColBrand).Value <> ""
' Section change if needed
If RowCurrent = 1 Then
RowSectionStart = RowCurrent
ElseIf ws.Cells(RowCurrent, ColBrand) <> ws.Cells(RowCurrent - 1, ColBrand) Then
RowSectionStart = RowCurrent
End If
If RowSectionStart <> RowCurrent Then
' Delete duplicate in Mil column
If Not Range(ws.Cells(RowSectionStart, ColMil), ws.Cells(RowCurrent - 1, ColMil)).Find(ws.Cells(RowCurrent, ColMil).Value) Is Nothing Then
ws.Cells(RowCurrent, ColMil).ClearContents
End If
' Delete duplicate in Color column
If Not Range(ws.Cells(RowSectionStart, ColColor), ws.Cells(RowCurrent - 1, ColColor)).Find(ws.Cells(RowCurrent, ColColor).Value) Is Nothing Then
ws.Cells(RowCurrent, ColColor).ClearContents
End If
End If
RowCurrent = RowCurrent + 1
Loop
Set ws = Nothing
End Sub
Esta imagen muestra el efecto del código. El contenido en las células de color amarillo se eliminan, puesto que ya están lo mencionan superior en el mismo 'sección'.
