Solved: Who can solve my matter

[vunhai]

Hi All,

I have one matter, i have file as attached , that file have some containers are duplicate, I want to find duplicates and highights (with multi colors as attached ) by code (vba). Please help me!


Minh Vu

[Bob Phillips]

[VBA]Public Sub Test()
Dim vecColours As Variant
Dim lastrow As Long
Dim idxColour As Long
Dim start As Long
Dim i As Long

vecColours = Array(65535, 15261367, 13082801) '<<< add more if extra coolours needed
idxColour = LBound(vecColours) - 1
With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow

If .Cells(i, "A").Value2 = .Cells(i - 1, "A").Value2 Then

start = i - 1
Do Until .Cells(i + 1, "A").Value2 <> .Cells(i, "A").Value2 Or i = lastrow

i = i + 1
Loop
idxColour = idxColour + 1

.Cells(start, "A").Resize(i - start + 1).Interior.Color = vecColours(idxColour)
End If
Next i
End With
End Sub[/VBA]

[vunhai]

Dear xld,

It's great! Thank you very much indeed! It' very helpful for me!

Minh Vu

[vunhai]

Dear xld!

thank you once again for your help, Please see attached file again how can i find duplicate and highlights as attached file. Please help me!

Minh Vu

[Bob Phillips]

Why didn't you give a real example to start with?

[VBA]Public Sub Test()
Dim rng As Range
Dim vecColours As Variant
Dim lastrow As Long
Dim idxColour As Long
Dim start As Long
Dim i As Long

vecColours = Array(65535, 15261367, 13082801) '<<< add more if extra coolours needed
idxColour = LBound(vecColours) - 1
With ActiveSheet

.Rows(1).Insert
.Range("B1").Value = "Temp"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("B2").Resize(lastrow - 1)
rng.Formula = "=COUNTIF(A:A,A2)&A2"
For i = 2 To lastrow

If Left$(.Cells(i, "B").Value2, 1) > 1 Then

If IsError(Application.Match(.Cells(i, "A").Interior.Color, vecColours, 0)) Then

.Columns(2).AutoFilter field:=1, Criteria1:="=" & .Cells(i, "B").Value2
idxColour = idxColour + 1
rng.Offset(0, -1).SpecialCells(xlCellTypeVisible).Interior.Color = vecColours(idxColour)
End If
End If
Next i

.Rows(1).Delete
.Columns("B").Clear
End With
End Sub[/VBA]

[vunhai]

Dear xld!

You are a magician really! Both of codes are great! Thank you very very much!! My matter is really solved!

Minh Vu.