Copier le texte d'une cellule et coller en commentaire sur 2500 lignes

Sub Macro1()
Sub cellcomment()
Dim I As Integer

For I = 4 To 2547
    Cells(I, "F").AddComment
    Cells(I, "F").Comment.Text Text:=Cells(I, "F").Value
Next I
End Sub

Option Explicit
Dim memCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim cmtarea As Single
    If Not memCell Is Nothing Then memCell.ClearComments
    Set memCell = Nothing
    If Target.Column <> 3 Or IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
    With Target
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:=Target.Value
        .Comment.Shape.TextFrame.AutoSize = True
        If .Comment.Shape.Width > 300 Then
            cmtarea = .Comment.Shape.Width * .Comment.Shape.Height
            .Comment.Shape.Width = 300
            .Comment.Shape.Height = (cmtarea / 300) * 1.15 + 3  ' (si besoin ajuster le paramètre 1.15)
        End If
    End With
    Set memCell = Target
End Sub