VBA to highlight duplicate data

[cmt_wright]

Hi,
I have the following data in tables in a spreadsheet, and I need a vba script that looks at the whole sheet and highlights any fruit (and adjacent data) that appears more than once (note that the bottom table contains an additional column of data which should also be highlighted).
I also need it to highlight the fruit in a different colour depending on how many times it is duplicated.
For example, pear appears twice, so could be highlighted yellow, apple and orange appear three times each so they could be red.

apple 2
orange 3
pear 2
kiwi 4
mango 5


bannana 3
grape 2
peach 4
apple 2
orange 3


blueberry 2 A
coconut 2 B
orange 3 C
apple 2 D
pear 2 E



This is a small chunk of the data, but the full set will have 20 fruits and maybe 10 tables of data to compare.
At the moment I have started to write a script that has loops within loops within loops, but this isn't going to be feasible/efficient for my larger set of data.

Does anyone have some code that they can share which achieves this more efficiently?
(my vba experience is moderate)

Many thanks!!!

 

[xenou]

I would suggest you insert a column to the left, or use an empty column off to the right somewhere, and place a count of each fruit in the column.

Use a Dynamic range name - that makes it very easy to get the count. Now you're conditional format need only evaluate this count.

For multiple colors, that's a bit more to ask. With many colors, you'll need vba - perhaps you could use the count as the color index. Or just use VBA to assign a color of choice to each count - again, easier since you only need to look at the count value in your new column.

Hope this helps.

On dynamic named ranges:
http://www.contextures.com/xlNames01.html

------------------------------------------
Sample idea of this column I'm talking about (you'd probably hide the column in actuality).

Formula in Cell D1 is =COUNTIF(Fruit,A1) where fruit is a dynamic named range of column A. It actually may be a little off since there's empty cells between tables - you may need to tweak it a little.

book1
	A	B	C	D
1	apple	2		2
2	orange	3		2
3	pear	2		1
4	kiwi	4		1
5	mango	5		1
6				0
7				0
8	bannana	3		1
9	grape	2		1
10	peach	4		1
11	apple	2		2
12	orange	3		2
13				0
14				0
15	blueberry	2	A	1
16	coconut	2	B	0
17	orange	3	C	2
18	apple	2	D	2
19	pear	2	E	1
Sheet1

 

[Legacy 68668]

VBA
try

Sub test()
Dim a, i As Long
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If Not IsEmpty(a(i, 1)) Then
            If Not .exists(a(i, 1)) Then .item(a(i, 1)) = VBA.Array("", 0)
            w = .item(a(i, 1))
            w(0) = w(0) & IIf(w(0)="","",",") & Cells(i, 1).Address(0,0)
            w(1) = w(1) + 1 : .item(a(i, 1)) = w
        End If
    Next
    For Each e In .items
        If e(1) <> 1 Then
            Select Case e(1)
                Case 2 : myClr = vbYellow
                Case 3 : myClr = vbRed
                Case 4 : myClr = vbBlue
                Case 5 : myClr = vbMagenta
                Case 6 : myClr = vbGreen
                Case Else : myClr = vbCyan
            End Select
            Range(e(0)).Interior.Color = myClr
        End If
    Next
End With
End Sub

 

[xenou]

Thanks Seiya for giving us a vba solution. I was posting back to say I have no idea why I used a dynamic named range - I think its because I added about 5 of them to a spreadsheet I was working on today. Just using the column would probably work for "Fruit" - i.e., =CountIf(A:A,A1) instead of =CountIf(Fruit,A1) Ah...time for sleep...

 

[Zack Barresse]

You never said what version. This is built into Excel 2007.

 

[cmt_wright]

Thanks so much for the replies. Very helpful.

Seiya, for the script you wrote, this works great, but how would it be changed to use a named range.
i.e. if I wanted to compare for duplicates within range "Fruit1", and then wanted to apply the colour format to range "Fruit2" (a different range).

I am using excel 2003.

Again, thanks fo the help.

 

[Legacy 68668]

try

Sub test()
Dim a, i As Long, w(), e
a = Range("fruit1").Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If Not IsEmpty(a(i, 1)) Then
            If Not .exists(a(i, 1)) Then .item(a(i, 1)) = VBA.Array("", 0)
            w = .item(a(i, 1))
            w(0) = w(0) & IIf(w(0)="","",",") & Range("fruit1").Cells(i, 1).Address(0,0)
            w(1) = w(1) + 1 : .item(a(i, 1)) = w
        End If
    Next
    a = Range("fruit2").Value
    For i = 1 To UBound(a, 1)
        If Not IsEmpty(a(i, 1)) Then
            If Not .exists(a(i, 1)) Then .item(a(i, 1)) = VBA.Array("", 0)
            w = .item(a(i, 1))
            w(0) = w(0) & IIf(w(0)="","",",") & Range("fruit2").Cells(i, 1).Address(0,0)
            w(1) = w(1) + 1 : .item(a(i, 1)) = w
        End If
    Next    
    For Each e In .items
        If e(1) <> 1 Then
            Select Case e(1)
                Case 2 : myClr = vbYellow
                Case 3 : myClr = vbRed
                Case 4 : myClr = vbBlue
                Case 5 : myClr = vbMagenta
                Case 6 : myClr = vbGreen
                Case Else : myClr = vbCyan
            End Select
            Range(e(0)).Interior.Color = myClr
        End If
    Next
End With
End Sub

 

[cmt_wright]

Maaaate....
That works a treat. Long live MrExcel!
Cheers.