coloring similar cells in values in the same column

[abuzainab73]

This code is coloring ( colorindex) that are input values in the times following the first time, and does not coloring the cell that a value is entered first in the case of similarity with other cells
And the desired color of all cells, including the first cell
How can an amendment to this code?



[vba]
Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:B100"

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Me.Range(WS_RANGE), Target.Value2) > 1 Then

If MsgBox("Accept Duplicate?", vbYesNo, "RepeatedValues") = vbYes Then

Target.Interior.ColorIndex = 40
Else

Target.Value2 = ""
End If
Else

Target.Interior.ColorIndex = xlNone
End If

Application.ScreenUpdating = True
End If
End Sub
[/vba]

[YasserKhalil]

Your request isn't clear my dear

[abuzainab73]

Try to open the attached file and enter in the cell (A8) for example, the value (2A3) ,then enter in the next cell (A9), the same value (2A3) you'll see a message box stating the value is repeating .when you press (yes) the
Result will be (second cell (A9) will be colored only "colorindex" )
Required: I need to color both cells (A8) + (A9) .

[slamet Harto]

untested
[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:B100"
Dim c As Range
If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Me.Range(WS_RANGE), Target.Value2) > 1 Then
Target.Interior.ColorIndex = 40

If MsgBox("Accept Duplicate?", vbYesNo, "RepeatedValues") = vbYes Then
Target.Interior.ColorIndex = 40
Set c = Range("A:A").Find(What:=Target, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=True)
If Not c Is Nothing Then
c.Interior.ColorIndex = 40
End If
Else

Target.Value2 = ""
End If
Else

Target.Interior.ColorIndex = xlNone
End If

Application.ScreenUpdating = True
End If
End Sub
[/VBA]

[khushii]

Required: I need to color both cells (A8) + (A9) .

I have tried adding Find Function It will color the first matching value in A column .[vba]Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:B100"
Dim DupliVal As Range

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Me.Range(WS_RANGE), Target.Value2) > 1 Then
Set DupliVal = Range(WS_RANGE).Find(Target.Value2)

If MsgBox("Accept Duplicate?", vbYesNo, "RepeatedValues") = vbYes Then

Target.Interior.ColorIndex = 40
DupliVal.Interior.ColorIndex = 40
Else

Target.Value2 = ""
End If
Else

Target.Interior.ColorIndex = xlNone
End If

Application.ScreenUpdating = True
End If
End Sub
[/vba]

Hope Its helps.

[Bob Phillips]

[vba]

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:B100"
Dim cell As Range

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Me.Range(WS_RANGE), Target.Value2) > 1 Then

If MsgBox("Accept Duplicate?", vbYesNo, "RepeatedValues") = vbYes Then

For Each cell In Me.Range(WS_RANGE)

If Application.CountIf(Me.Range(WS_RANGE), cell.Value2) > 1 Then

cell.Interior.ColorIndex = 40
End If
Next cell
Else

Target.Value2 = ""
End If
Else

Target.Interior.ColorIndex = xlNone
End If

Application.ScreenUpdating = True
End If
End Sub
[/vba]

[Bob Phillips]

Here is a more efficient way, along the lines that Slamet was suggesting

[vba]

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:B100"
Dim cell As Range
Dim FirstAddress As String

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Me.Range(WS_RANGE), Target.Value2) > 1 Then

If MsgBox("Accept Duplicate?", vbYesNo, "RepeatedValues") = vbYes Then

Set cell = Me.Range(WS_RANGE).Find(Target.Value2)
FirstAddress = cell.Address
Do

cell.Interior.ColorIndex = 40
Set cell = Me.Range(WS_RANGE).FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
Else

Target.Value2 = ""
End If
Else

Target.Interior.ColorIndex = xlNone
End If

Application.ScreenUpdating = True
End If
End Sub
[/vba]

[abuzainab73]

Slamet Harto,
Khushii,
Xld ,

all codes operate efficiently.


Thank you from the depths of my heart
for helping me to modify the code.


Best regards.
Abuzainab73

[abuzainab73]

I am v.sory

this code is coloring all cells in the range (a1:b100) in the case have same value .
but I need to color the cell only which they are similar in the same column ( not in the range "a1:b100" )
for example :

aaaaa A aaaaaB
1 aaaa25aaaa25
2 aaaa24aaaa24
3 aaaa20aaaa20
4 aaaa21aaaa19
5 aaaa25aaaa21
6 aaaa26aaaa23
7aaaaa27aaaa24

So the code- -after Modification - will color the cell ( A1 ) + ( A5 ) because they have same value(25) and they are in the same colmun (A) . But it will not color the cell (B1) which has same value (25) beceuse it is in anoter culumn(B) .

In the colmun (B) the code will color the cell(B2) + (B7)
because they have same value ( 24) and they are in the same colmun (B) and it will not color the cell ( A2 ) which has same value (24 ) .


I hope that I have been able to explain my request to modify the code.

[Bob Phillips]

[vba]

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A:B"
Dim cell As Range
Dim FirstAddress As String

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
Application.ScreenUpdating = False

If Application.CountIf(Target.EntireColumn, Target.Value2) > 1 Then

Set cell = Target.EntireColumn.Find(Target.Value2)
FirstAddress = cell.Address
Do

cell.Font.ColorIndex = 3
Set cell = Me.Range(WS_RANGE).FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
Else

Target.Font.ColorIndex = xlColorIndexAutomatic
End If

Application.ScreenUpdating = True
End If
End Sub
[/vba]

[abuzainab73]

I have this cod And it work well . but I want to add a message box as in the previous codes.
[VBA]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim R As Integer, C As Integer
If Not Intersect(Target, Range("N8:aq78")) Is Nothing Then
Application.ScreenUpdating = False
C = Target.Column
For R = 8 To 78
If Cells(R, C) <> "" And Application.CountIf(Range(Cells(8, C), Cells(80, C)) Cells(R, C)) > 1 Then
Cells(R, C).Interior.ColorIndex = 39
Else
Cells(R, C).Interior.ColorIndex = xlNone
End If
Next
Application.ScreenUpdating = True
End If
End Sub
[/VBA]

[nandakumar]

hi,
try with conditional formatting.
go to Format->conditional formatting

[Simon Lloyd]

Conditional formatting wouldn't give the overall functionality he is looking for but is a great suggestio, to highlight all duplicates you would use:
=COUNTIF($A$1:$A$100,A1)>1
or using a named range
=COUNTIF(MyRange,A1)>1
Where MyRange would be the name of your named range.