export word review comments in excel

Try:

Sub ExportComments()

Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object

StrCmt = "Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date"

StrCmt = Replace(StrCmt, ",", vbTab)

With ActiveDocument

  ' Process the Comments

  For i = 1 To .Comments.Count

    With .Comments(i)

      StrCmt = StrCmt & vbCr & .Reference.Information(wdActiveEndAdjustedPageNumber) & _

        vbTab & .Author & vbTab & .Date & vbTab

      With .Scope

        If InStr(.Paragraphs(1).Style, "Heading") = 1 Then

          StrCmt = StrCmt & .Paragraphs(1).Range.ListFormat.ListString & vbTab

        Else

          StrCmt = StrCmt & ParentLevel(.Paragraphs(1)) & vbTab

        End If

        With .Duplicate

          .End = .End - 1

          StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab

        End With

      End With

      With .Range.Duplicate

        .End = .End - 1

        StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")

      End With

    End With

  Next

  StrTmp = .Name

End With

' Test whether Excel is already running.

On Error Resume Next

Set xlApp = GetObject(, "Excel.Application")

'Start Excel if it isn't running

If xlApp Is Nothing Then

  Set xlApp = CreateObject("Excel.Application")

  If xlApp Is Nothing Then

    MsgBox "Can't start Excel.", vbExclamation

    Exit Sub

  End If

End If

On Error GoTo 0

With xlApp

  Set xlWkBk = .Workbooks.Add

  ' Update the workbook.

  With xlWkBk.Worksheets(1)

    .Name = StrTmp

    .Columns("D").NumberFormat = "@"

    For i = 0 To UBound(Split(StrCmt, vbCr))

      StrTmp = Split(StrCmt, vbCr)(i)

        For j = 0 To UBound(Split(StrTmp, vbTab))

          .Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)

        Next

    Next

    .Columns("A:L").AutoFit

    .Columns("E:F").ColumnWidth = 25

  End With

  ' Tell the user we're done.

  MsgBox "Workbook updates finished.", vbOKOnly

  ' Switch to the Excel workbook

  .Visible = True

End With

' Release object memory

Set xlWkBk = Nothing: Set xlApp = Nothing

End Sub

Function ParentLevel(Para As Paragraph) As String

Dim ParaHd As Paragraph, StrTmp As String

Set ParaHd = Para

Do While ParaHd.OutlineLevel = Para.OutlineLevel

  Set ParaHd = ParaHd.Previous

Loop

ParentLevel = ParaHd.Range.ListFormat.ListString

End Function

Rather than taking up extra columns for every possible heading level (there could be as many as 9 in a Word document), those data are all output to a single column. The levels should remain quite apparent, there.

The following modification of my code in the thread at:

http://answers.microsoft.com/en-us/profile/5846a56b-3e92-46d7-b5bf-4f65922e1f56?sort=lastreplydate&dir=desc&tab=qna&forum=&filter=All&page=1&tm=1374543937262

will create a new document containing a table that displays the Page Number, the number of the Section in the document, the line number, the text upon which the comment is made, the text of the comment and the name of the person who made the comment.

If the text upon which the comment was made, the table will include the contents of the cell that contain that text.  If the text is not in a table, it will display the text of the first paragraph to which the comment applies

 Dim source As Document, target As Document

 Dim tblTarget As Table

 Dim rowTarget As Row

 Dim i As Long, j As Long, p As Long, s As Long

 Dim strComment As String

 Dim strinitials As String

 Dim rngText As Range

 Set source = ActiveDocument

 Set target = Documents.Add

 Set tblTarget = target.Tables.Add(target.Range, 1, 6)

 With tblTarget

     .Cell(1, 1).Range.Text = "Page"

     .Cell(1, 2).Range.Text = "Section"

     .Cell(1, 3).Range.Text = "Line"

     .Cell(1, 4).Range.Text = "Text"

     .Cell(1, 5).Range.Text = "Comment"

     .Cell(1, 6).Range.Text = "Name"

 End With

 With source

     For i = 1 To .Comments.Count

         p = .Comments(i).Reference.Information(wdActiveEndPageNumber)

         s = .Comments(i).Reference.Information(wdActiveEndSectionNumber)

         l = .Comments(i).Reference.Information(wdFirstCharacterLineNumber)

         Set rngText = .Comments(i).Reference

        If rngText.Information(wdWithInTable) = True Then

            Set rngText = .Comments(i).Reference.Cells(1).Range

            rngText.End = rngText.End - 1

        Else

            Set rngText = .Comments(i).Reference.Paragraphs(1).Range

            rngText.End = rngText.End - 1

        End If

         strComment = .Comments(i).Range.Text

         strinitials = .Comments(i).Author

         Set rowTarget = tblTarget.Rows.Add

         With rowTarget

             .Cells(1).Range.Text = p

             .Cells(2).Range.Text = s

             .Cells(3).Range.Text = l

             .Cells(4).Range.Text = rngText.Text

             .Cells(5).Range.Text = strComment

             .Cells(6).Range.Text = strinitials

         End With

     Next i

 End With

Fantastic! Just what I was looking for and works perfectly for me. Thank you!