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