VBA

[Jack in the UK]

Hi guys a good one wonder if you have any cool ideas on:

Say Col a is names john, chris, ivan, mark, barrie, aladin, mudface and so on..

but poss 3 jack, i need to highlight all different colours and all 3 jack or what ever the same colour whereever they are in that col.

Trick is with a twist, no 2 diff nems must be the same colour???

Ermm any ideas...... also this must work with dates input by crtl+:


Cheers guys for looking....

[Mark O'Brien]

I think this is what you want, I took your example data and copied it a few times down column 1.

The code assumes the first value is in A1. The "iNotBlack" variable can be set to anything, except 1. 1 is the colour code for black. I don't really like the colour code 8 throws up, so you might want to mess about with this variable to get pleasing colours.

Public Sub ColourCells()

'Declare

  Dim oFirstCell As Range

  Dim oLastCell As Range

  Dim oRange As Range

  Dim oTargetRange As Range

  Dim sNameArray() As String

  Dim iColourArray() As Integer

  Dim i As Integer

  Dim iNotBlack as Integer

  

'Intialise

  With Sheets("Sheet1")

    Set oFirstCell = .Range("A1")

    Set oLastCell = .Cells(.Range("A65536").End(xlUp).Row, 1)

    Set oRange = .Range(oFirstCell.Address, oLastCell.Address)

  End With

  

  ReDim sNameArray(1)

  ReDim iColourArray(1)

  iNotBlack  = 1



'Create Unique name array

  For Each oTargetRange In oRange

    For i = 1 To UBound(sNameArray)

      If oTargetRange.Value = sNameArray(i) Then

        Exit For

      End If

    Next

      ReDim Preserve sNameArray(i)

      sNameArray(i) = oTargetRange.Value

      ReDim Preserve iColourArray(i)

      iColourArray(i) = i + iNotBlack

  Next

  

'Go through the range again, but this time setting colours

  For Each oTargetRange In oRange

    For i = 2 To UBound(sNameArray)

        If oTargetRange.Value = sNameArray(i) Then

          With oTargetRange.Interior

            .ColorIndex = iColourArray(i)

            .Pattern = xlSolid

          End With

      End If

    Next

  Next



End Sub