Excel. Changing Interior Color to match a cell with same value-CodePudding

Morning all. Just a quick one for you!

I have two tables of times, and I'm looking to get the bottom tables interior colors to match the top tables. I'm wanting to do this in VBA as both table ranges are dynamic with a data refresh, I currently have a ForEach loop on the lower table with a named range (cpttimes), and the top tables times are in a named range too (times) if i can squeeze in some code in to set the interior.color at the same time that would be great! Had a look online already, but struggling to find some tidy code :)

Tried a couple of methods so far but falling up short :)

Any ideas??

CodePudding user response：

Please, use the next way. I tested the code on two tables existing in the same sheet. You should set them exactly as you need (in separate sheets, the code will also work):

Sub matchTableColors()
  Dim tbl1 As ListObject, tbl2 As ListObject, i As Long, dbRng As Range, mtchCell As Range
  
  Set tbl1 = ActiveSheet.ListObjects("ColoredTableName") 'the one having colored cells
  Set tbl2 = ActiveSheet.ListObjects("ToBeColoredTbl")   'the one to be colored
  
  Set dbRng = tbl2.DataBodyRange
  'Debug.Print dbRng.address, tbl1.DataBodyRange.address: Stop
  For i = 1 To dbRng.rows.count
        Set mtchCell = tbl1.DataBodyRange.Find(What:=dbRng.cells(i, 1).Text, LookIn:=xlValues, lookat:=xlWhole)

        If Not mtchCell Is Nothing Then
             dbRng.cells(i, 1).Interior.Color = mtchCell.Interior.Color
        End If
  Next i
End Sub

Note: The column width in the second table must be fit or larger than necessary to see all text. I mean dbRng.cells(i, 1).Text returns the visible text....

Edited:

Please, use the next code to process two ranges (instead of tables)

Sub matchNamedRngColors()
  Dim rng1 As Range, rng2 As Range, i As Long, mtchCell As Range
  
  Set rng1 = ActiveSheet.Range("Name1")
  Set rng2 = ActiveSheet.Range("Name2")
  
  For i = 1 To rng2.rows.count
        Set mtchCell = rng1.Find(What:=rng2.cells(i, 1).Text, LookIn:=xlValues, lookat:=xlWhole)

        If Not mtchCell Is Nothing Then
             rng2.cells(i, 1).Interior.Color = mtchCell.Interior.Color
        End If
  Next i
End Sub

Please, send some feedback after testing it