extraire un commentaire dans une cellule

Sub Liste_Commentaires()
    Dim Lecture As String, Inter As String
    Dim Pointeur1 As Long, Pointeur2 As Long, Fin As String, Début As Long
    Dim CaseDébut As Object
    Dim Sortir As Boolean
    Set CaseDébut = Range("A:IV").Find("Commentaires", LookIn:=xlValues)
    If CaseDébut Is Nothing Then
        MsgBox "Pas de traitement, l'entête  <Commentaires>  n'a pas été trouvée"
    Else
        Fin = Left(CaseDébut.Address, 3)
        Feuil2.Range("A:A").ClearContents
        Pointeur2 = 1
        For Pointeur1 = 2 To 1000
            If Not Range(Fin & Pointeur1).Comment Is Nothing Then _
                    Lecture = Range(Fin & Pointeur1).Comment.Text
            Début = 1
            Sortir = False
            Do
                If InStr(1, Lecture, Chr(10)) > 0 Then
                    Inter = Left(Lecture, InStr(1, Lecture, Chr(10)) - 1)
                Else
                    Inter = Lecture
                    Sortir = True
                End If
                Set CaseDébut = Feuil2.Range("A:A").Find(Inter, LookIn:=xlValues)
                If CaseDébut Is Nothing Then
                    Inter = Replace(Replace(Replace(Inter, "M. ", ""), "Mme ", ""), "Mlle ", "")
                    Feuil2.Range("A" & Pointeur2) = Inter
                    Pointeur2 = Pointeur2 + 1
                End If
                Lecture = Mid(Lecture, InStr(1, Lecture, Chr(10)) + 1)
            Loop Until Inter = "" Or Sortir
            Lecture = ""
        Next Pointeur1
    End If
    Feuil2.Select
    Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
    Range("B1").Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(ActiveCell, [B6:K1000]) Is Nothing Then Exit Sub
[A2] = "" 'RAZ
On Error Resume Next
[A2] = ActiveCell.Comment.Text
End Sub