KleurenZoeker - pas de celkleur aan volgens de kleur die in een tabel staat

[SjofaaSj]

Ik heb een tabel met codes en een bereik waar deze codes worden ingevuld.
In de tabel heeft elke code een kleur en ik wil deze ook in de tabel weergeven
Ik wil geen voorwaardelijke opmaak gebruiken maar dit via VBA oplossen

Het lukt deels met deze code

Sub UpdateColors()
    Dim rng As Range, cell As Range
    Dim myTbl As ListObject, ColHdr As String, TblCol As Long, TblRow As Long
    Dim LookupVal As Variant
    Dim myCell As Variant
'PRM
    Set myTbl = Sheets("kleuren").ListObjects("T_kleuren")
    Set rng = Range("rngInput")
    ColHdr = "CODE"
    TblCol = Application.WorksheetFunction.Match(ColHdr, myTbl.HeaderRowRange, 0)
'GO
    For Each cell In rng
        myCell = cell.Value
        myadr = cell.Address
        TblRow = Application.WorksheetFunction.Index(myTbl.ListColumns(TblCol).DataBodyRange, Application.WorksheetFunction.Match(myCell, myTbl.ListColumns(1).DataBodyRange)).Row
        cell.Interior.ColorIndex = myTbl.DataBodyRange.Cells(TblRow, TblCol).Interior.ColorIndex
    Next cell
    
End Sub

De code crasht echter als de waarde een punt is (staat nochtans in de tabel) en cijfers worden niet geformatteerd.

Is dit de meest efficiënte manier om de kleur op te halen en hoe kan ik cijfers en tekens eveneens laten meekleuren?

Alvast bedankt.

 

[edmoor]

Doe dit eens achter het blad input en voer dan de Sub Kleuren uit:

Sub Kleuren()
    Application.ScreenUpdating = False
    For Each cl In ActiveSheet.UsedRange
        cl.Interior.Color = GetKleur(cl.Value)
    Next cl
    Application.ScreenUpdating = True
End Sub

Function GetKleur(Sleutel) As Long
    With Sheets("Kleuren")
        For Each cl In .Range("B4:B14")
            If cl.Value = Sleutel Then
                GetKleur = cl.Interior.Color
                Exit Function
            End If
        Next cl
    End With
End Function

 

[SjofaaSj]

DIEPE BUIGING

Dankjewel edmoor !