Error Checking in Excel
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: VBA

  1. #1
    Board Regular
    Join Date
    Feb 2002
    Posts
    3,184
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

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


    Free Excel based Web Toolbar available here.

    Jack in the UK
    J & R Excel Solutions
    "making Excel work for you"

  2. #2
    MrExcel MVP Mark O'Brien's Avatar
    Join Date
    Feb 2002
    Location
    Columbus, OH, USA
    Posts
    3,530
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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



Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •