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]

I believe I figured out the code change to make it color all cells only in the selected range.

That's right, it should be:

With .Resize(lr - iniR + 1).SpecialCells(xlCellTypeConstants) 'populated cells

With .Resize(lr - iniR + 1)  'all cells

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

I suspected it from the beginning
Then try this:

Sub Coloring_Rows()
  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 i = iniR To lr
    If Not dic.exists(Cells(i, iniC).Value) Then
      dic(Cells(i, iniC).Value) = dic.Count + 1      'Unique in rows
    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 i = iniR To lr
    With Cells(i, iniC)
      m = arr(dic(.Value), 1)
      With .Resize(1, lc - iniC + 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

Remember
Populated cells:
With .Resize(1, lc - iniC + 1).SpecialCells(xlCellTypeConstants)
All cells:
With .Resize(1, lc - iniC + 1)

Examples:

--------------
Cordially
Dante Amor
--------------

 

[JakeP]

Hello Dante,

I will test this more tomorrow on actual data at work, but so far all versions seem to work great!!
Will report back.

Thanks so much for your help!!
JP

 

[JakeP]

Hello Dante,

Your solutions work great for what I was trying to accomplish!
Thank you very much for your time and effort.

Kind regards, JP