Cells.Find(What:=Chr(10), After:=ActiveCell, LookIn:=xlComments, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate

Dim FirstAddress As String, Found As Range, Acc As Range
Set Found = Cells.Find(What:=Chr(10), After:=Cells(1, 1), LookIn:=xlComments)
If Found Is Nothing Then Exit Sub
FirstAddress = Found.Address
Set Acc = Found
Do
  Set Acc = Application.Union(Acc, Found)
  Set Found = Cells.Find(What:=Chr(10), After:=Found, LookIn:=xlComments)
Loop Until Found.Address = FirstAddress
Acc.Activate