Word Macro help

[Sam1085]

Hi,

I have a macro to extract all comments, user name and page number to a separate Word file as a table format (herewith I have attached).

Question is, I attempted to add a new column to get 'file name' from the document. I used below mentioned property.

Code: Select all

ThisDocument.Name

But ThisDocument.Name property returned to Macro file name instead of document file name.
Can you help me to get document file name into the table?

Thank you!

[HansV]

Use ActiveDocument.Name instead of ThisDocument.Name

[Sam1085]

Hi Hans,

Thank you for quick reply.
I applied ActiveDocument.Name.
But it returned as Document[#] instead of my saved document name.

[HansV]

Sorry, that should have been source.Name

[Sam1085]

Thank you Hans. That works perfectly!

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.

[HansV]

Do you want to run it on all documents in a folder? Or on all open documents? Or …?

[Sam1085]

I Need to run selected documents in a folder.

[HansV]

Try this version:

Code: Select all

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.

[macropod]

FWIW, the following macro does much the same, except that the destination is a new Excel workbook:

Code: Select all

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

[Sam1085]

FWIW, the following macro does much the same, except that the destination is a new Excel workbook:

Code: Select all

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!

[Sam1085]

Try this version:

Code: Select all

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.

[HansV]

Sorry, a typo. It should be .SelectedItems(j)

[Sam1085]

Hi Hans,

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).

[Charles Kenyon]

Try:

target.activate

[Sam1085]

Hi Charles,

Thanks for help. [target.activate] is working!!
Thank you everyone!

[HansV]

You could also add a line

Code: Select all

                .Close SaveChanges:=False

Just below the line

Code: Select all

                Next i

[Sam1085]

FWIW, the following macro does much the same, except that the destination is a new Excel workbook:

Code: Select all

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!

[HansV]

Here is a modified version of Paul's macro:

Code: Select all

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

[Sam1085]

Thank you Hans for your time and effort.
Now everything perfectly work. I will do few adjustments for my work.

[Sam1085]

Hi Hans,

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?

Thank you!