Microsoft 365 Mettre à jour les couleurs des cellules sur une page selon des cellules dans une autre page

Sub majCouleurEmission()

ActiveSheet.Unprotect Password:="xxxxx"
Application.ScreenUpdating = False
    
Dim rngSource As Range
Dim rngCible As Range
Dim rngCell As Range
Dim shSource As Worksheet, shCible As Worksheet
Dim destRngSearch As Range, destDateRngSearch As Range, destPrjRngSearch As Range
Dim prjFound As Range, dteFound As Range
Dim prjSearch As String, dteSearch As String, columnLetter As String, dteFoundColLetter As String

    Set shSource = Worksheets("Planification_Général")
    Set shCible = Worksheets("Planification")
    Set rngSource = shSource.Range("Planif_General") 'Nom du tableau source
    
    For Each rngCell In rngSource
        If rngCell.Interior.ColorIndex <> xlNone And rngCell.ColumnWidth > 0 Then
            
            prjSearch = shSource.Range("A" & rngCell.Row).Text
            columnLetter = Split(Cells(1, rngCell.Column).Address, "$")(1)
            dteSearch = shSource.Range(columnLetter & "3").Text
            shCible.Activate
            ActiveSheet.Unprotect Password:="xxxxx"
            Set destDateRngSearch = shCible.Rows(3)
            Set destPrjRngSearch = shCible.Columns("A")
            Set prjFound = destPrjRngSearch.Find(what:=prjSearch)
            
                If Not prjFound Is Nothing Then
                        Set dteFound = destDateRngSearch.Find(what:=dteSearch)
                        If Not dteFound Is Nothing Then
                                dteFoundColLetter = Split(Cells(1, dteFound.Column).Address, "$")(1)
                                Range(dteFoundColLetter & prjFound.Row).Interior.ColorIndex = rngCell.Interior.ColorIndex
                        End If
                End If
            shSource.Activate 
        End If
    Next rngCell
    
    
Application.ScreenUpdating = True
ActiveSheet.Protect Contents:=True, AllowFiltering:=True, AllowSorting:=True, Password:="xxxxx"
End Sub