VBA occurencies not working

[Darkveemon1]

Hi, I'm making a simple VBA SubI, but it is giving me some problems.

I have a column with some values and I want to higlight the occurencies (a value is repeated), but the first tiem the value appears it should not be higlighted.

Fro Example:
if I have a column like this:

d
d
d
a
e
f
a
w
it should color the background of cell D6, D7 and D11 (my first cell is D5)

The problem with the code is that it works the first iteration, but then changes the value D6 to the value it is checking in the For loop, so in the end D6 is blue, but with "w" in it instead of "d" and D7 and D11 are still blank

Sub Pulsante1_Click()

Dim wb As Workbook
Dim tld As Worksheet
Dim supportoTLD As Range 'my column
Dim ricerca, confronta As Range 'ricerca is the cell I will be confronting every time, 'confronta is the cell the cell after it and so on in the second loop
Dim i, j As Integer 'row index

Set wb = ThisWorkbook
Set tld = wb.Sheets("Foglio1")
Set supportoTLD = tld.Columns("D:D")
Set ricerca = tld.Cells(5, 4)
Set confronta = tld.Cells(6, 4)

    For i = 5 To Range("D5").End(xlDown).Row - 1
        For j = 6 To Range("D5").End(xlDown).Row
        ricerca = tld.Cells(i, supportoTLD.Column).Value
        confronta = tld.Cells(j, supportoTLD.Column).Value
        If confronta = ricerca Then
        confronta.Interior.ColorIndex = 37
        End If
        Next j
    Next i
   
End Sub

 

[Tom Urtis]

Based on your description, this would do what you want.

Sub Test1()
Application.ScreenUpdating = False
Dim LastRow&, cell As Range, ColorRange As Range
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Set ColorRange = Range("D5:D" & LastRow).SpecialCells(2)
ColorRange.Interior.ColorIndex = 0
For Each cell In ColorRange
If WorksheetFunction.CountIf(Range("D5:D" & cell.Row), cell.Value) > 1 Then cell.Interior.ColorIndex = 37
Next cell
Set ColorRange = Nothing
Application.ScreenUpdating = True
End Sub

 

[Darkveemon1]

Thanks for the reply, but why are you using:

LastRow = Cells(Rows.Count, 4).End(xlUp).Row? Instead of End (xlDown)?

 

[Darkveemon1]

Based on your description, this would do what you want.

Sub Test1()
Application.ScreenUpdating = False
Dim LastRow&, cell As Range, ColorRange As Range
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Set ColorRange = Range("D5:D" & LastRow).SpecialCells(2)
ColorRange.Interior.ColorIndex = 0
For Each cell In ColorRange
If WorksheetFunction.CountIf(Range("D5:D" & cell.Row), cell.Value) > 1 Then cell.Interior.ColorIndex = 37
Next cell
Set ColorRange = Nothing
Application.ScreenUpdating = True
End Sub

Thx for the help, tomorrow I'll test it and let you know. Why are you using End.xlup instead of End.xlDown? In the third row.

I should scroll from top to bottom, no?

 

[Joe4]

Why are you using End.xlup instead of End.xlDown? In the third row.

I should scroll from top to bottom, no?

That will find your REAL last row with data in that column.
If you may have blank cells in the middle of your column, xlDown will stop at the first blank, and not go down to the absolute bottom.

If you have no blank cells in the middle of your data column, either way will work just fine. But if you might, xlUp is what you need.
So xlUp should always work, while xlDown only sometimes works.

 

[Joe4]

Here is a simple test to prove my previous explanation.

First, here is the code:

Sub MyTest()

    Dim d As Long
    Dim u As Long
    
'   Find last row using xlDown, starting from row 1
    d = Cells(1, "A").End(xlDown).Row
    
'   Find last row using xlUp, starting from last possible row in column
    u = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Return results:
    MsgBox "Last row using xlDown method: " & d & vbCrLf & _
            "Last row using xlUp method: " & u
            
End Sub

And here is a screen print of a simple bit of data, and the results of the code when run:

 

[Darkveemon1]

Based on your description, this would do what you want.

Sub Test1()
Application.ScreenUpdating = False
Dim LastRow&, cell As Range, ColorRange As Range
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Set ColorRange = Range("D5:D" & LastRow).SpecialCells(2)
ColorRange.Interior.ColorIndex = 0
For Each cell In ColorRange
If WorksheetFunction.CountIf(Range("D5:D" & cell.Row), cell.Value) > 1 Then cell.Interior.ColorIndex = 37
Next cell
Set ColorRange = Nothing
Application.ScreenUpdating = True
End Sub

Thank you, I tried it this morning and it works perfectly!