compare and color cells with similar values in a column using vba

  • Thread starter Thread starter noname
  • Start date Start date
N

noname

Hi,
i have a column which has values like:
col A
1
1
1
2
2
2
2
3
3
4
4
4

i want to compare each cell with other cells in column and see if they
are same, if so color similar cells with the same color. so you have
groups of similar cells colored the same.
 
Hi,
i have a column which has values like:
col A
1
1
1
2
2
2
2
3
3
4
4
4

i want to compare each cell with other cells in column and see if they
are same, if so color similar cells with the same color. so you have
groups of similar cells colored the same.
Click to expand...

this has to be implemented in a code, so i need a VBA solution and not
a worksheet solution.

Thanks.
 
Might give this a shot:
Sub ColorTheSameValueCells()
Const myColumn As String = "A" '<--column whose cells to be
compared
Dim RangeToCheck As Range
Dim oneCell As Range, oneCell2 As Range
Dim currentValue As Long '<--assumed that values are always of
LONG type
Dim currentColorIndex As Long '<--holds color index

Set RangeToCheck = ActiveSheet.Columns("A"). _
SpecialCells(xlCellTypeConstants) '<-- will loop through every
_
cell in the column that contains a value

RangeToCheck.Interior.ColorIndex = xlNone 'Reset color to none

For Each oneCell In RangeToCheck
If oneCell.Interior.ColorIndex = xlNone Then
currentValue = oneCell.Value
On Error GoTo RunOutOfColors:
currentColorIndex = currentColorIndex + 1 '<-- might _
run out of colors if there are too many different
values
On Error GoTo 0
For Each oneCell2 In RangeToCheck
With oneCell2
If .Value = currentValue Then
.Interior.ColorIndex = currentColorIndex
End If
End With
Next oneCell2
End If
Next oneCell

Exit Sub
RunOutOfColors:
oneCell.Select
MsgBox "Run out of colors on the selected cell!", vbExclamation

End Sub
 
:)
Obviously this one:
Set RangeToCheck = ActiveSheet.Columns("A").
was supposed to be:
Set RangeToCheck = ActiveSheet.Columns(myColumn).

As otherwise there was no point in the constant...
 
:)
Obviously this one:
Set RangeToCheck = ActiveSheet.Columns("A").
was supposed to be:
Set RangeToCheck = ActiveSheet.Columns(myColumn).

As otherwise there was no point in the constant...
Click to expand...

Thanks. it works.
i want to implement this for the data series groups for an XY Scatter
chart, so the points of each data series groups are colored the same.

Any ideas on how to do this?
 
I don't know if i understood correctly, but try this one - I plugged
in also a bit of code that finds points in the chart with the same
value is in the cell and paints the point in the same color as the
cell. There are some un-elegant things in the code (like, it reads
chart values multiple times but actually it doesn't need to - once
would suffice) but it works and I don't think it should cause you
problems.

Sub ColorTheSameValueCells()
Const myColumn As String = "A" '<--column whose cells to be
compared
Dim RangeToCheck As Range
Dim oneCell As Range, oneCell2 As Range
Dim currentValue As Long '<--assumed that values are always of
LONG type
Dim currentColorIndex As Long '<--holds color index
Dim chartValues(), arrNdx As Long

Set RangeToCheck = ActiveSheet.Columns("A"). _
SpecialCells(xlCellTypeConstants) '<-- will loop through every
_
cell in the column that contains a value

RangeToCheck.Interior.ColorIndex = xlNone 'Reset color to none

For Each oneCell In RangeToCheck
If oneCell.Interior.ColorIndex = xlNone Then
currentValue = oneCell.Value
On Error GoTo RunOutOfColors:
currentColorIndex = currentColorIndex + 1 '<-- might _
run out of colors if there are too many different
values
On Error GoTo 0
'paint the cells
For Each oneCell2 In RangeToCheck
With oneCell2
If .Value = currentValue Then
.Interior.ColorIndex = currentColorIndex
End If
End With
Next oneCell2
'paint the dots on the chart
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
chartValues = .Values
For arrNdx = LBound(chartValues) To
UBound(chartValues)
If chartValues(arrNdx) = currentValue Then
.Points(arrNdx).MarkerForegroundColorIndex =
currentColorIndex
.Points(arrNdx).MarkerBackgroundColorIndex =
currentColorIndex
End If
Next arrNdx

End With
End If
Next oneCell

Exit Sub
RunOutOfColors:
oneCell.Select
MsgBox "Run out of colors on the selected cell!", vbExclamation

End Sub
 
Back
Top