XL 2019 Copier le contenu d'une cellule dans un commentaire sur une autre feuille

[procruste]

Bonjour à tous !

Après avoir chercher sur le forum j'ai trouvé une partie de réponse à mes questions.
Mais je suis toujours bloqué à certains endroit.
Je cherche à faire une macro qui dirait dans un horaire (Feuille Horaire) qui travail au poste et qui est formé au poste.
Cela se fait actuellement via des commentaires lié à une base de donnée (Base Commentaire).
Cela fonctionne mais je voudrais garder la mise en forme dans ma connexion. (Exemple, le titulaire du poste est en bleu dans la base de donnée, je voudrais qu'il soit aussi en bleu dans les commentaires).
Autre point, je n'arrive pas à adapter le code pour que le lien entre la base de donnée et le commentaire se fasse dans la feuille horaire et non dans la feuille "test survol"

Merci d'avance !

PJ le fichier

 

[Rouge]

Bonjour,

Proposition, les couleurs des polices ne sont pas tout à fait les mêmes, mais cela reste acceptable.

Option Explicit

Private Sub Worksheet_Activate()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, i As Long, NbCar_Poste As Long, NbCar_Titulaire As Long, NbCar_Remplaçant As Long
    Dim f1 As Worksheet, f2 As Worksheet
    Dim p As Range
    Dim Deb As String
    
    Application.ScreenUpdating = False
    Set f1 = Sheets("Horaire")
    Set f2 = Sheets("Base Commentaire")
    DerLig_f1 = f1.Range("E" & Rows.Count).End(xlUp).Row
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    f1.Cells.ClearComments
    
    ReDim Poste(DerLig_f2) As String
    ReDim Titulaire(DerLig_f2) As String
    ReDim Remplaçant(DerLig_f2) As String
    For i = 2 To DerLig_f2
        Poste(i) = f2.Cells(i, "A")
        Titulaire(i) = f2.Cells(i, "B")
        Remplaçant(i) = f2.Cells(i, "C")
    Next i
    
    For i = 2 To DerLig_f2
        With f1.Columns(5)
            Set p = .Find(Poste(i), lookat:=xlWhole)
            If Not p Is Nothing Then
                Deb = p.Address
                Do
                    f1.Cells(p.Row, 5).AddComment (Titulaire(i) & ", " & Remplaçant(i))
                    NbCar_Poste = Len(Titulaire(i) & ", " & Remplaçant(i))
                    NbCar_Titulaire = Len(Titulaire(i))
                    NbCar_Remplaçant = Len(Remplaçant(i))
                    f1.Cells(p.Row, 5).Comment.Shape.TextFrame.Characters(1, NbCar_Titulaire).Font.Color = RGB(255, 150, 150)
                    f1.Cells(p.Row, 5).Comment.Shape.TextFrame.Characters(NbCar_Titulaire + 1, NbCar_Poste).Font.Color = RGB(50, 120, 30)
                    Set p = .FindNext(p)
                Loop While Not p Is Nothing And p.Address <> Deb
            End If
        End With
    Next i
End Sub

Cdlt

 

[procruste]

Merci pour cette réponse Rouge !
Effectivement ca fonctionne bien !
Mais j'ai changé mon code car le précèdent était un peu rigide à mon gout !
Voici le nouveau code

Private Sub Worksheet_Activate()

 

With Feuil3

        .Cells.ClearComments

  For Each C In [D11:D111]

   If C <> "" Then

    Set p = Application.Index([Base], , 1).Find(what:=C, lookat:=xlWhole)

    If Not p Is Nothing Then

       temp = p.Offset(0, 17) & vbLf & p.Offset(0, 18) & vbLf & p.Offset(0, 19) & vbLf & p.Offset(0, 20)

       If C.Comment Is Nothing Then C.AddComment

       C.Comment.Text Text:=temp

       C.Comment.Shape.TextFrame.AutoSize = True

     End If

   End If

  Next C

End With

End Sub

Il est plus facile d'adaptation. Pense tu que tu pourrais adapter ton code de couleur par rapport au colonnes que je vais chercher dans ma base de données ?

 

[Rouge]

Pour ne pas donner une solution erronée, il eut été plus facile pour moi de travailler sur un fichier plutôt que sur un bout de code.
Est-il possible d'avoir le fichier avec cette nouvelle configuration?