Recherche d'une couleur pour remonter une information

Bonjour,

Je n'arrive pas à construire mon programme afin que je puisse récupérer l'information d'une case (une date) si une autre case est en jaune.
Je m'explique: Mon fichier est un planning de production. Sur la gauche, j'ai en colonne toutes mes pièces à produire. Sur la droite, j'ai en ligne les différentes étapes à suivre pour réaliser mon produit. En haut se trouve une echelle du temps avec les dates jour par jour.

Ce que je cherche à faire: En mettant une étape de production en jaune, je voudrais pouvoir récupérer la date associé à cette étape sur une case de la ligne (entre le nom du produit et le découpage des opérations).

J'ai récupérer un programme mais je n'arrive pas à l'adapter et/ou le simplifier:

A savoir: Mon fichier s'appelle 'MPS'
Les étapes que je veux mettre en jaune s'appelle "EM2" et "BHF"

Dim lCol As Long
    Dim nbrFAT As Long
    Dim c As Range
    Dim sCmdEnCours As String
    Dim sPos As String
    Dim sPosAvant As String
    Dim vCouleur
    
    ' Recherche des Postes EM2 dont la Couleur de Fond de la Cellule est Jaune
    With Sheets("MPS").Range("S4:IV65536")
        Set c = .Find("EM2", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            sCmdEnCours = c.Address
            Do
                .Range(c.Address).Select
                sPos = ActiveCell.Row
                If sPos <> sPosAvant Then
                    vCouleur = ActiveCell.Interior.ColorIndex
                    If vCouleur = giJaune Then
                        lCol = ActiveCell.Column
                        If IsEmpty(.Range("N" & sPos)) Then
                            .Range("N" & sPos) = Sheets("MPS").Cells(10, lCol)
                            .Range("N" & sPos).Interior.Color = glJaune
                            nbrFAT = nbrFAT + 1
                            If Val(gsVersion) = 12 Then
                                .Range("N" & sPos).Interior.TintAndShade = 0
                                .Range("N" & sPos).Interior.PatternTintAndShade = 0
                            End If
                        End If
                    End If
                    sPosAvant = sPos
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> sCmdEnCours
        End If
    End With
    
    ' Recherche des Postes BHF dont la Couleur de Fond de la Cellule est Jaune ou Violette
    sPosAvant = ""
    With Sheets("MPS").Range("S4:IV65536")
        Set c = Nothing
        Set c = .Find("BHF", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            sCmdEnCours = c.Address
            Do
                .Range(c.Address).Select
                sPos = ActiveCell.Row
                If sPos <> sPosAvant Then
                    vCouleur = ActiveCell.Interior.ColorIndex
                    If vCouleur = giJaune Then
                        lCol = ActiveCell.Column
                        .Range("N" & sPos) = Sheets("MPS").Cells(10, lCol)
                        .Range("N" & sPos).Interior.Color = glJaune
                        nbrFAT = nbrFAT + 1
                        If Val(gsVersion) = 12 Then
                            .Range("N" & sPos).Interior.TintAndShade = 0
                            .Range("N" & sPos).Interior.PatternTintAndShade = 0
                        End If
                    End If
                    sPosAvant = sPos
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> sCmdEnCours
        End If
    End With
    Sheets("MPS").Range("P4").Select
    Application.ScreenUpdating = True

Par avance merci pour votre aide
Caziag