VBA Cell Coloring - Not Conditional Formatting

[Daniel Goondar Z]

Hi all,

let's see who can help me with this next excel vba question:
I have a list that consists of several names (text or number strings - representing names and codes, usually 1-20 different strings), some repeating only once, and some several times.
I'd like to sort by name (easy) and to color each name (each group of cells) in a different color (super hard), in an automatic way using a macro.
I do not want a fixed color for each name as the names vary on a daily basis, and I'd like them to be visually different from each other, so I can better differentiate each group of cells (in conditional formatting the scale shades are too similar sometimes. For this task it is best to use excels 56 colors: from 2 to 15 and from 21-28 and from 39-51).

Please, if anyone thinks he can do this I'll be forever grateful!

 

[MickG]

Try this for data in column "A".

[COLOR="Navy"]Sub[/COLOR] MG24Sep42
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
c = 1
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = c + 1
    c = IIf(c = 16, 21, c)
    c = IIf(c = 29, 39, c)
    c = IIf(c = 51, 2, c)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            Dn.Interior.ColorIndex = c
            .Add Dn.Value, c
        [COLOR="Navy"]Else[/COLOR]
            Dn.Interior.ColorIndex = .Item(Dn.Value)
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Daniel Goondar Z]

Try this for data in column "A".

[COLOR=Navy]Sub[/COLOR] MG24Sep42
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
c = 1
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    c = c + 1
    c = IIf(c = 16, 21, c)
    c = IIf(c = 29, 39, c)
    c = IIf(c = 51, 2, c)
        [COLOR=Navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
            Dn.Interior.ColorIndex = c
            .Add Dn.Value, c
        [COLOR=Navy]Else[/COLOR]
            Dn.Interior.ColorIndex = .Item(Dn.Value)
        [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Amazing!
I have no idea how it even works, but the important thing is that it does! thank you so much!

 

[MickG]

You're welcome
Regrds Mick