Tjek celleindhold i andet ark

Ville nok være lidt lettere at gennemskue, hvis jeg havde mulighed for at se filen.

Du er velkommen til at sende den til: pb@supertekst-it.dk

Forslag - koden indsat i ThisWorkbook:
======================================

Dim ark_Krækker, ark_Crækker
Dim farver As String, ws As Worksheet, antalFejl
Sub kontrolAfFarver()
Dim okFarver
    antalFejl = 0
   
Rem beregn antal rækker i de to ark
    ark_Krækker = beregnAntalRækker("kilde")
    ark_Crækker = beregnAntalRækker("colour")
   
Rem gennemløb af kolonne H i arket kilde
    Set ws = ActiveWorkbook.Sheets("kilde")
    With ActiveSheet
        For ræk = 2 To ark_Krækker
            farver = .Range("H" & CStr(ræk)) + ","
            okFarver = checkFarver(farver)
           
            If okFarver = "" Then
                .Range("I" & CStr(ræk)) = ""
            Else
                .Range("I" & CStr(ræk)) = okFarver
                antalFejl = antalFejl + 1
            End If
        Next ræk
    End With
   
    MsgBox ("Farvekontrol udført - " & antalFejl & " fejlcelle(r)")
End Sub
Private Function beregnAntalRækker(arkNavn)
    Set ws = ActiveWorkbook.Worksheets(arkNavn)
    beregnAntalRækker = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1
End Function
Private Function checkFarver(farver)
Dim fejlFarve As String
    fejlFarve = ""
   
    While InStr(farver, ",") > 0
        p = InStr(farver, ",")
        If p > 0 Then
            farve = Trim(Left(farver, p - 1))
            If findesFarve(farve) = False Then
                fejlFarve = fejlFarve + farve + "|"
            End If
            farver = Mid(farver, p + 1)
        End If
    Wend
    checkFarver = fejlFarve
End Function
Private Function findesFarve(farve)                          'check om farve findes i colour-arket
Dim ws, ræk
    Set ws = ActiveWorkbook.Sheets("Colour")
   
    With ws.Range("B2:B" & CStr(ark_Crækker))
        Set c = .Find(farve, LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                ræk = c.Row
                findesFarve = True
            Else
                findesFarve = False
            End If
    End With
End Function