PDA

View Full Version : coloring similar cells in values in the same column



abuzainab73
07-26-2010, 02:45 PM
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
07-26-2010, 03:04 PM
Your request isn't clear my dear

abuzainab73
07-26-2010, 11:30 PM
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
07-27-2010, 01:24 AM
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
07-27-2010, 01:26 AM
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
07-27-2010, 02:20 AM
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
07-27-2010, 02:26 AM
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
07-27-2010, 03:51 AM
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
07-31-2010, 01:58 AM
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
07-31-2010, 03:18 AM
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
07-31-2010, 07:44 AM
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
08-03-2010, 09:16 AM
hi,
try with conditional formatting.
go to Format->conditional formatting

Simon Lloyd
08-03-2010, 09:27 AM
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.