[Résolu] Copier le contenu d'une cellule dans un commentaire

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3:B6")) Is Nothing Then
        ImportCommentaire
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$9" Then
        ImportCommentaire
    End If
End Sub

Sub ImportCommentaire()
' copier le contenu des cellules E3, E4, E5 et E6 de la feuille "BASE"
' insérer dans les cellules B3, D3, F3 et H3 de la feuille "Socle com" sous forme de commentaires
' la macro s'exécute à chaque changement de valeur dans la plage (E3:E6) de la feuille "BASE"
' et dans la cellule D9 de la feuille "Réglages"
' le tout sur des feuilles protégées par le mot de passe suivant : deblock

' 1) ' copier le contenu des cellules E3, E4, E5 et E6 de la feuille "BASE"
Dim Fbase As Worksheet
Set Fbase = Worksheets("BASE")
Dim i As Integer
Dim Tbase(0 To 3) As Variant
    For i = LBound(Tbase) To UBound(Tbase)
        Tbase(i) = Fbase.Cells(3 + i, 5)
    Next i
    i = Empty

' 2) ' le tout sur des feuilles protégées par le mot de passe suivant : deblock
Dim Fsocle As Worksheet
Set Fsocle = Worksheets("Socle com")
' Déprotéger
Fsocle.Unprotect ("deblock")
' Traiment remplire commentaire
    Dim j As Integer
    j = 2
    For i = LBound(Tbase) To UBound(Tbase)
        Fsocle.Cells(3, j).ClearComments
        Fsocle.Cells(3, j).AddComment
        Fsocle.Cells(3, j).Comment.Visible = False
        Fsocle.Cells(3, j).Comment.Text Text:=Tbase(i)
    j = j + 2
    Next i
i = Empty
j = Empty

Fsocle.Protect ("deblock")
Fsocle.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub