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?




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

[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
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

[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 .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


Hope Its helps.: pray2:

[Bob Phillips]

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

[Bob Phillips]

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



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

[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]

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

[abuzainab73]

I have this cod And it work well . but I want to add a message box as in the previous codes.

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

[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.