Compare cell values in each row change background color

[Samadhan Gaikwad]

Hi,

I've 7 columns and having many rows and want to highlight same values in each rows and apply some random color. Here I want to compare all values separately in each row. Have added image to illustrate things.

 

[Kenneth Hobson]

I don't see that being random color by each row. If it was random, the first two columns would not have the same color.

Did you have some set of colors that you wanted it to pick as color1, color2, etc? If it did, I could see that the first two columns would have the same colors.

 

[Samadhan Gaikwad]

I think I shouldn't have used random colors. There might be set of predefined 7 colors since I've 7 colors and the sequence of colors would be same.

 

[Kenneth Hobson]

Always test code in a backup copy.

As shown in the comments, change the color values and range to suit. Add the Microsoft Scripting reference object.

In a Module:

Sub Main()
  Dim r As Range, c As Range, cc As Range
  Dim i As Integer, a, b, d

  'Change range to suit.
  Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Resize(, 7)

  'Colors, change to suit.
  a = Array(8421504, 15849925, 11851260, 5296274, 12611584, 65535, 10498160)

  For Each c In r.Rows
    b = UniqueArrayByDict(c.Value)
    'd = WorksheetFunction.Transpose(WorksheetFunction.Transpose(b))
    For i = 1 To c.Cells.Count
      c.Cells(, i).Interior.Color = a(PosInArray(c.Cells(, i).Value, b))
    Next i
  Next c
End Sub

Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary    'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

'If array is 0 based, 1 is returned if aValue matches anArray(0).
Function PosInArray(aValue, anArray)
  Dim pos As Long, i As Long
  On Error Resume Next
  pos = -1

  For i = LBound(anArray) To UBound(anArray)
    If anArray(i) = aValue Then
      pos = i
      Exit For
    End If
  Next i

  'pos = WorksheetFunction.Match(CStr(aValue), anArray, 0)
  PosInArray = pos
End Function

 

[Samadhan Gaikwad]

I'm just amazed with the macro. It's just working as expected. Thank you so much @Kenneth Hobson