One more thing I need to clarify.
Is it possible to run this macro into multiple files to extract information?
Let's say if I have ABC.docx and DEF.docx files (both files have comments).
How can I extract comments, pg numbers.. etc to a single report? Can you provide me a guidance.
Sub Macro()
Dim strFile As String
Dim j As Long
Dim source As Document, target As Document
Dim tblTarget As Table
Dim rowTarget As Row
Dim i As Long, p As Long
Dim strComment As String
Dim strinitials As String
Dim rngText As Range
With Application.FileDialog(1) ' msoFileDialogOpen
.AllowMultiSelect = True
If .Show = False Then
Beep
Exit Sub
End If
Set target = Documents.Add
Set tblTarget = target.Tables.Add(target.Range, 1, 4)
For j = 1 To .SelectedItems.Count
strFile = .SelectedItems(i)
Set source = Documents.Open(FileName:=strFile)
With tblTarget
.Cell(1, 1).Range.Text = "Page Number"
.Cell(1, 2).Range.Text = "User Name"
.Cell(1, 3).Range.Text = "Comment Text"
End With
With source
For i = 1 To .Comments.Count
p = .Comments(i).Reference.Information(wdActiveEndPageNumber)
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 = strinitials
.Cells(3).Range.Text = strComment
.Cells(4).Range.Text = source.Name
End With
Next i
End With
Next j
End With
End Sub
Sub ExportComments()
' Note: A reference to the Microsoft Excel # Object Library
' is required, set via Tools|References in the Word VBE.
Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
StrCmt = "Page,Author,Date & Time,Comment"
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
StrCmt = StrCmt & Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
Next
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)
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:C").AutoFit
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
Sub ExportComments()
' Note: A reference to the Microsoft Excel # Object Library
' is required, set via Tools|References in the Word VBE.
Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
StrCmt = "Page,Author,Date & Time,Comment"
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
StrCmt = StrCmt & Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
Next
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)
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:C").AutoFit
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
Thank you Paul. Your code is working perfectly. But I need to extract into a Word doc.
Thanks again for your effort and code!
Sub Macro()
Dim strFile As String
Dim j As Long
Dim source As Document, target As Document
Dim tblTarget As Table
Dim rowTarget As Row
Dim i As Long, p As Long
Dim strComment As String
Dim strinitials As String
Dim rngText As Range
With Application.FileDialog(1) ' msoFileDialogOpen
.AllowMultiSelect = True
If .Show = False Then
Beep
Exit Sub
End If
Set target = Documents.Add
Set tblTarget = target.Tables.Add(target.Range, 1, 4)
For j = 1 To .SelectedItems.Count
strFile = .SelectedItems(i)
Set source = Documents.Open(FileName:=strFile)
With tblTarget
.Cell(1, 1).Range.Text = "Page Number"
.Cell(1, 2).Range.Text = "User Name"
.Cell(1, 3).Range.Text = "Comment Text"
End With
With source
For i = 1 To .Comments.Count
p = .Comments(i).Reference.Information(wdActiveEndPageNumber)
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 = strinitials
.Cells(3).Range.Text = strComment
.Cells(4).Range.Text = source.Name
End With
Next i
End With
Next j
End With
End Sub
I haven't tested it, please do so carefully.
Thank you Hans for your code.
I just tried to run safely in my test Word document.
But line 21 [strFile = .SelectedItems(i)] returned to run time error 5.
Thanks for the code. It working perfectly.
One small thing.. Is it possible to focus newly generated Word after run this macro? (currently focusing selected Word files after run this macro).
Sub ExportComments()
' Note: A reference to the Microsoft Excel # Object Library
' is required, set via Tools|References in the Word VBE.
Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
StrCmt = "Page,Author,Date & Time,Comment"
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
StrCmt = StrCmt & Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
Next
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)
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:C").AutoFit
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
Hi,
I'm looking to Export page numbers, comments, user name with file name from multiple Word files to a single Excel file.
Above macro is working fine but need to change two things:
1. Add Word file name to Excel file
2. Choose multiple files using file dialog box
I tried to Export Word generated table to Excel Worksheet. But it looks like too hard.
Can you help me to provide a solution.
Thank you!
Sub ExportComments()
Dim StrCmt As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
Dim strFile As String, strTmp2, source As Document, blnStart As Boolean
With Application.FileDialog(1) ' msoFileDialogOpen
.AllowMultiSelect = True
If .Show = False Then
Beep
Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(Class:="Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject(Class:="Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
blnStart = True
End If
On Error GoTo 0
StrCmt = "Page,Author,Date & Time,Comment,Document"
StrCmt = Replace(StrCmt, ",", vbTab)
For j = 1 To .SelectedItems.Count
strFile = .SelectedItems(j)
Set source = Documents.Open(FileName:=strFile)
With source
' Process the comments
For i = 1 To .Comments.Count
With .Comments(i)
StrCmt = StrCmt & vbCr & _
.Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab & _
Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>") & _
vbTab & source.Name
End With
Next i
.Close SaveChanges:=False
End With
Next j
End With
With xlApp
' Create new workbook with a single worksheet
Set xlWkBk = .Workbooks.Add(-4167)
' Update the workbook.
With xlWkBk.Worksheets(1)
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 j
Next i
.Columns("A:D").AutoFit
End With
' Tell the user we're done.
MsgBox "Workbook updates finished.", vbInformation
' Switch to the Excel workbook
If blnStart Then
.Visible = True
End If
AppActivate xlWkBk.Name
End With
' Release object memory
Set xlWkBk = Nothing
Set xlApp = Nothing
End Sub
If there's no comment on a selected Word file, is there any way to add document name and add a comment (ex: No comments available) to as a new row in the table?