Sub CommentsToCells()
    Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim i As Long
Set xlapp = GetObject(, "Excel.Application")
If Err Then
    Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.Workbooks.Add
Set xlsheet = xlbook.Worksheets(1)
With xlsheet.Range("A1")
    .Offset(0, 0) = "Comment #"
    .Offset(0, 1) = "Author"
    .Offset(0, 2) = "Comment"
    .Offset(0, 3) = "Date"
End With
With ActiveDocument
    For i = 1 To .Comments.Count
        xlsheet.Range("A1").Offset(i, 0) = i
        xlsheet.Range("B1").Offset(i, 0) = .Comments(i).Author
        xlsheet.Range("C1").Offset(i, 0) = .Comments(i).Range.Text
        xlsheet.Range("D1").Offset(i, 0) = .Comments(i).Scope.Text
        xlsheet.Range("E1").Offset(i, 0) = .Comments(i).Date
    Next i
End With
End Sub