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
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
[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]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Dear xld,
It's great! Thank you very much indeed! It' very helpful for me!
Minh Vu
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
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]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Dear xld!
You are a magician really! Both of codes are great! Thank you very very much!! My matter is really solved!
Minh Vu.