VBA Excel macro to apply a unique color to end of each column (to the end of values, not entire column) only if header name is present and unique

[JakeP]

Hi, I've been unsuccessfully trying to create a macro to apply a random but unique color (light cell color with black font or dark cell color with white font) to all values in each column, only if header name is present and uniquely named. (all headers and/or cell values could be alpha/numeric), empty cells can remain white or if easier they can be the same color as the rest of that column.
Columns with same exact header name should be the same color. Can be many rows, but I don't expect to have more than about 30-50 columns but if it could be the max allowable that would be perfect.
Would like to be able to use this in future workbooks, therefore conditional formatting is not really desired.

In the future, I would also like to be able to do the same thing with rows instead of columns.

Many, many thanks for any suggestions!!

 

[DanteAmor]

Hello @JakeP. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Each unique header will have its own (random) color.
For example:

Try the following macro.

Sub Coloring()
  Dim i&, j&, m&, x&, y&, lr&, lc&
  Dim arr As Variant
  Dim dic As Object

  lr = Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = Cells(1, Columns.Count).End(1).Column
  With Range("A1", Cells(lr, lc))
    .Interior.Color = xlNone
    .Font.Color = vbBlack
  End With

  Set dic = CreateObject("Scripting.Dictionary")
  For j = 1 To lc
    If Not dic.exists(Cells(1, j).Value) Then
      dic(Cells(1, j).Value) = dic.Count + 1      'Unique headers
    End If
  Next
  
  Randomize
  arr = Evaluate("ROW(1:130)")                    'random color
  For i = 1 To UBound(arr)
    x = Int(UBound(arr) * Rnd + 1)
    y = arr(i, 1)
    arr(i, 1) = arr(x, 1)
    arr(x, 1) = y
  Next i
  
  For j = 1 To lc
    With Cells(1, j)
      m = arr(dic(.Value), 1)
      With .Resize(lr).SpecialCells(xlCellTypeConstants)
        .Interior.Color = 8388608 + (m * 5000)    'initial color for 1
        If m Mod 13 < 7 Then .Font.Color = vbWhite
      End With
    End With
  Next
End Sub

If you want all cells:

Change this line:

With .Resize(lr).SpecialCells(xlCellTypeConstants)

By this line:

With .Resize(lr)

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[JakeP]

Hello Dante,
Thanks so much for the warm welcome and the effort to work on this macro.
I put this in a module for the file that contains the worksheet shown below.
I selected the desired range, ran the macro and got the following runtime error message.
Thanks again, JakeP

 

[JakeP]

 

[JakeP]

Hi Dante,
I moved the range so it begins at A1 and tried the both versions again.
They seem to work quite good like this however, seems some of the lighter interiors have white fonts and difficult to read.
If this easy to fix, it would very nice.
Also it would be great if both versions could work on a selected range as opposed to starting at A1.
Thanks again!!
JP

 

[DanteAmor]

... seems some of the lighter interiors have white fonts and difficult to read.

I made some adjustments, I hope it looks better .

Also it would be great if both versions could work on a selected range as opposed to starting at A1.

Ok, now it works with cell selection . (For the second version of the macro, you must change the same line )

Sub Coloring_v2()
  Dim i&, j&, m&, x&, y&, lr&, lc&, iniR&, iniC&
  Dim arr As Variant
  Dim dic As Object

  With Selection
    .Interior.Color = xlNone
    .Font.Color = vbBlack
    iniR = .Cells(1).Row
    iniC = .Cells(1).Column
    lc = .Columns.Count + iniC - 1
    lr = .Rows.Count + iniR - 1
  End With
 
  Set dic = CreateObject("Scripting.Dictionary")
  For j = iniC To lc
    If Not dic.exists(Cells(iniR, j).Value) Then
      dic(Cells(iniR, j).Value) = dic.Count + 1      'Unique headers
    End If
  Next
 
  Randomize
  arr = Evaluate("ROW(1:130)")                    'random color
  For i = 1 To UBound(arr)
    x = Int(UBound(arr) * Rnd + 1)
    y = arr(i, 1)
    arr(i, 1) = arr(x, 1)
    arr(x, 1) = y
  Next i
 
  For j = iniC To lc
    With Cells(iniR, j)
      m = arr(dic(.Value), 1)
      With .Resize(lr).SpecialCells(xlCellTypeConstants)
        .Interior.Color = 8388608 + (m * 5000)    'initial color for 1
        If m Mod 13 >= 1 And m Mod 13 <= 5 Then .Font.Color = vbWhite
      End With
    End With
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[JakeP]

Hi Dante,
Getting very close
Both work on the selected range now, however both versions apply colors passed (below) the selected range.
You can see the top selection does not color empty cells, but the colors that did apply extended into the lower range of data.

I made the changes to code to color all cells and tried it on the lower selected range and you can see how far below the colors extended.
I think the font colors will be hard to get visibly matched with the appropriate interior color unless you know some tricks to solve for this.

Thank you, JP

 

[DanteAmor]

Both work on the selected range now, however both versions apply colors passed (below)

Fixed

I think the font colors will be hard to get visibly matched with the appropriate interior color

I think fixed. Look at the image:

Please try again:

Sub Coloring_v2()
  Dim i&, j&, m&, x&, y&, lr&, lc&, iniR&, iniC&
  Dim arr As Variant
  Dim dic As Object

  With Selection
    .Interior.Color = xlNone
    .Font.Color = vbBlack
    iniR = .Cells(1).Row
    iniC = .Cells(1).Column
    lc = .Columns.Count + iniC - 1
    lr = .Rows.Count + iniR - 1
  End With
  
  Set dic = CreateObject("Scripting.Dictionary")
  For j = iniC To lc
    If Not dic.exists(Cells(iniR, j).Value) Then
      dic(Cells(iniR, j).Value) = dic.Count + 1      'Unique headers
    End If
  Next
  
  Randomize
  arr = Evaluate("ROW(1:130)")                    'random color
  For i = 1 To UBound(arr)
    x = Int(UBound(arr) * Rnd + 1)
    y = arr(i, 1)
    arr(i, 1) = arr(x, 1)
    arr(x, 1) = y
  Next i
  
  For j = iniC To lc
    With Cells(iniR, j)
      m = arr(dic(.Value), 1)
      With .Resize(lr - iniR + 1).SpecialCells(xlCellTypeConstants)
        .Interior.Color = 8388608 + (m * 5000)    'initial color for 1
        If m Mod 13 >= 1 And m Mod 13 <= 6 Then .Font.Color = vbWhite
      End With
    End With
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[JakeP]

Hello Dante,
This version seems to work much better! Nice job!!

I tried the code change to the version that colored the entire range, it looks good but still applies colors below the selected range.
Is that previous line of code changed before still valid in this latest code version?

I hate to ask, but would be it be to much, if you could change this to work the same way for rows instead of columns?

Thanks again!!

 

[JakeP]

Hello Dante,
I believe I figured out the code change to make it color all cells only in the selected range.
Thank your VERY much for your quick and knowledgeable support!!

What do you think about changes to have it work for rows instead of columns?

BR, JP