Dear Team,
I want to create macro which shall fetch the threaded comment list from word document in which Original comment and comment responses to be captured in separate columns. E.g in case if word para is having comment for which there are 4 replies then original comment shall be in first column and next four columns shall capture the 4 replies. Please find below in-progress macro for reference
Sub CopyCommentsToExcel_SB1_WIP()
'Create in Word vba
Dim xlApp As Object
Dim xlWB As Object
Dim i As Integer
Dim HeadingRow As Integer
Dim objPara As Paragraph
Dim objComment As Comment
Dim strSection As String
Dim strTemp
Dim myRange As Range
Dim oComments As Comments
Dim oComment As Comment
Dim lngIndex As Long
Dim iR As Long
Dim IRCol As Long
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
With xlWB.Worksheets(1)
' Below code Creates and controls Heading in excel file
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "SR#"
.Cells(HeadingRow, 2).Formula = "Page#"
.Cells(HeadingRow, 3).Formula = "OriginalText"
.Cells(HeadingRow, 4).Formula = "CommentText"
.Cells(HeadingRow, 5).Formula = "Name"
.Cells(HeadingRow, 6).Formula = "Date"
.Cells(HeadingRow, 7).Formula = "DocumentName"
.Cells(HeadingRow, 8).Formula = "Comment Type"
.Cells(HeadingRow, 9).Formula = "Resolved ?"
.Cells(HeadingRow, 10).Formula = "Replies#"
End With
With xlWB.Worksheets(1)
' For i = 1 To ActiveDocument.Comments.Count 'Original loop
For i = 1 To ActiveDocument.Comments.Count
.Cells(i + 1, 1).Formula = ActiveDocument.Comments(i).Index
.Cells(i + 1, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
.Cells(i + 1, 3).Formula = ActiveDocument.Comments(i).Scope
.Cells(i + 1, 4).Formula = ActiveDocument.Comments(i).Range.Text
.Cells(i + 1, 5).Formula = ActiveDocument.Comments(i).Contact
.Cells(i + 1, 6).Formula = Format(ActiveDocument.Comments(i).Date, "dd-MMM-YY")
.Cells(i + 1, 7).Formula = ActiveDocument.Comments.Parent
.Cells(i + 1, 8).Formula = ""
' .Cells(i + 1, 8).Formula = Format(Range("H2").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
' Formula1:="Orange,Apple,Mango,Pear,Peach)
.Cells(i + 1, 9).Formula = ActiveDocument.Comments(i).Done
.Cells(i + 1, 10).Formula = ActiveDocument.Comments(i).Replies.Count
' .Cells(i + 1, 9).Formula = ActiveDocument.Comments(i).Ancestor.Index
' .Cells(i + 1, 7).Formula = ActiveDocument.Comments.Count
' .Cells(i + 1, 8).Formula = ActiveDocument.Comments.Application
' .Cells(i + 1, 9).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
' .Cells(i + 1, 4).Formula = ActiveDocument.Comments(i).Initial
' Set oComments = ActiveDocument.Comments
' For Each oComment In oComments
' If oComment.Replies.Count > 0 Then
' For lngIndex = 1 To oComment.Replies.Count
' MsgBox oComment.Replies(lngIndex).Range.Text
' Next
' End If
Set oComments = ActiveDocument.Comments
For Each oComment In oComments
If oComment.Replies.Count > 0 Then
For lngIndex = 1 To oComment.Replies.Count
' MsgBox oComment.Replies(lngIndex).Range.Text
iR = 1
IRCol = 11
For iR = 1 To oComment.Replies.Count
.Cells(1, IRCol).Formula = "Reply " & iR
' .Cells(i, IRCol).Formula = oComment.Replies(lngIndex).Range.Text
' = oComment.Replies(iR).Creator _
' & vbCrLf _
' & oComment.Replies(iR).Date _
' & vbCrLf _
' & oComment.Replies(lngIndex).Range.Text
IRCol = IRCol + 1
Next iR
Next
End If
Next
'lbl_Exit:
'Exit Sub
Next i
End With
'Creating the the table from the the captured content from current sheet
'With xlWB.Worksheets(1)
'.ListObjects.Add(xlSrcRange,
'.Cells(1, 1)
'.CurrentRegion, , xlYes)
'.Name = ""
'End With
''Changing the Table Style only
'Set mylist = newwks.ListObjects(1)
'mylist.TableStyle = "TableStyleLight7"
'listcols = mylist.DataBodyRange
'.Columns.Count
''Below code block is for formatting the captured content only
'With mylist.DataBodyRange
'.Cells.VerticalAlignment = xlTop
'.Columns.EntireColumn.ColumnWidth = 30
'.Cells.WrapText = True
'.Columns.EntireColumn.AutoFit
'.Rows.EntireRow.AutoFit
'End With
'With xlWB.Worksheets(1)
' Range("Q2").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
' Formula1:="Orange,Apple,Mango,Pear,Peach"
'End With
Application.ScreenUpdating = True
Set xlWB = Nothing
Set xlApp = Nothing
End Sub