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

[DomGagner]

Bonjour,

Comme indiqué sur l'image en pièce jointe, je souhaite transférer les couleurs de remplissage des cellules d'un tableau sur une feuille excel vers un autre tableau sur une autre feuille excel. Il y a plusieurs couleurs différente dans mon premier tableau qui sont associé à différents numéro de projet et date. Je veux les mettre à jour dans le deuxième tableau, mais le deuxième tableau peut contenir plusieurs fois le numéro de projet associé au premier tableau.

Je ne sais pas si je suis clair dans mon explication, je l'espère

J'ai une ébauche de code qui ne semble marcher que pour la première couleur qu'il trouve dans la première feuille mais ne semble pas aller plus loins.

Merci pour votre aide.

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

 

[Oneida]

Bonjour,
Les couleurs de la premiere page sont affectees comment: par code VBA ou MFC?

 

[DomGagner]

Bonjour,
Les couleurs de la premiere page sont affectees comment: par code VBA ou MFC?

Par code VBA

 

[DomGagner]

Personne ne peux m'aider?

 

[DomGagner]

En haut. Je cherche toujours une solution a mon problème