Macro to maintain formatting OR to delete all text (excluding comments)

jimmy12 · #1 05-14-2021, 06:31 AM

Hi,

I have been using a Macro for some time that extracts all text in a Word that had been covered/highlighted by a comment, and inserts it into a new, separate Word document. However, the only issue is that the extracted text does not maintain the existing formatting of the original document, i.e. same font, same font size etc.. I'm not quite sure how best to edit my Macro for that function?

Code:

Sub AnalyseComments()
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long

Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count

'Create a new document for the comments
Set oNewDoc = Documents.Add
'Insert a 4-column table for the comments
With oNewDoc
  .Content = ""
  Set oTable = .Tables.Add _
    (Range:=Selection.Range, _
    numrows:=nCount + 1, _
    NumColumns:=4)
End With

With oTable.Rows(1)
  .Range.Font.Bold = True
  .Cells(1).Range.Text = "Page"
  .Cells(2).Range.Text = "Comment scope"
  .Cells(3).Range.Text = "Comment text"
  .Cells(4).Range.Text = "Author"
End With
 
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
  With oTable.Rows(n + 1)
    'Page number
    .Cells(1).Range.Text = _
      oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
    'The text marked by the comment
    .Cells(2).Range.Text = oDoc.Comments(n).Scope
    'The comment itself
    .Cells(3).Range.Text = oDoc.Comments(n).Range.Text
    'The comment author
    .Cells(4).Range.Text = oDoc.Comments(n).Author
  End With
Next n

oNewDoc.Activate
MsgBox "Finished creating comments document."
 
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing

End Sub

Alternatively, I thought about another Macro that would delete all text in the original document, but specifically excluding any text that had been covered/highlighted by a comment. This would therefore create a document with just the commented text and maintain the formatting. However, I'm a bit of a loss of creating this code.

I'd be grateful for any advice if anyone is able to help.

Guessed · #2 05-14-2021, 06:44 PM

Firstly, the formatting of text pasted into another document often adapts its look because the style definitions in both docs differs. You can avoid that by creating the new document using the current document. Next you should use Range.FormattedText instead of Range.Text. Then, if you aren't pasting paragraph marks then you probably need to apply the same paragraph style.

When it comes to local formatting, the two red lines 'should' have worked on my machine but they didn't - perhaps you will have more luck with it.

Code:

Sub AnalyseComments()
  Dim oDoc As Document, oNewDoc As Document, oTable As Table
  Dim aCom As Comment, nCount As Long, n As Long
  
  Set oDoc = ActiveDocument
  nCount = ActiveDocument.Comments.Count
  
  'Create a new document for the comments
  Set oNewDoc = Documents.Add(Template:=ActiveDocument.FullName)
  oNewDoc.Range.Delete
  
  'Insert a 4-column table for the comments
  With oNewDoc
    .Content = ""
    Set oTable = .Tables.Add(Range:=Selection.Range, numrows:=nCount + 1, NumColumns:=4)
  End With
  
  With oTable.Rows(1)
    .Range.Font.Bold = True
    .Cells(1).Range.Text = "Page"
    .Cells(2).Range.Text = "Comment scope"
    .Cells(3).Range.Text = "Comment text"
    .Cells(4).Range.Text = "Author"
  End With
  
  'Get info from each comment from oDoc and insert in table
  For n = 1 To nCount
    Set aCom = oDoc.Comments(n)
    With oTable.Rows(n + 1)
      .Cells(1).Range.Text = aCom.Scope.Information(wdActiveEndPageNumber)      'Page number
      .Cells(2).Range.Style = aCom.Scope.Paragraphs(1).Style  'apply the same paragraph style
      .Cells(2).Range.FormattedText = aCom.Scope.FormattedText    'The text marked by the comment
      .Cells(2).Range.Font = aCom.Scope.Font    'this fails even when same attributes over whole range
      .Cells(3).Range.Text = aCom.Range.Text    'The comment itself
      .Cells(4).Range.Text = aCom.Author    'The comment author
    End With
  Next n
  
  oNewDoc.Activate
  MsgBox "Finished creating comments document."
  
  Set oDoc = Nothing
  Set oNewDoc = Nothing
  Set oTable = Nothing
  Set aCom = Nothing

End Sub

macropod · #3 05-14-2021, 09:24 PM

Try:

Code:

Sub AnalyseComments()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Tbl As Table, Rng As Range, r As Long
Set DocSrc = ActiveDocument
'Create a new document for the comments
Set DocTgt = Documents.Add
'Insert a 4-column table for the comments
With DocTgt
  .Content = ""
  Set Tbl = .Tables.Add(Range:=.Range, NumRows:=DocSrc.Comments.Count + 1, NumColumns:=4)
  With Tbl
    With .Rows(1)
      .Range.Font.Bold = True
      .Cells(1).Range.Text = "Page"
      .Cells(2).Range.Text = "Comment scope"
      .Cells(3).Range.Text = "Comment text"
      .Cells(4).Range.Text = "Author"
    End With
    'Get info from each comment from DocSrc and insert in table
    For r = 1 To .Rows.Count
      With .Rows(r + 1)
        'Page number
        .Cells(1).Range.Text = DocSrc.Comments(r).Scope.Information(wdActiveEndPageNumber)
        'The text marked by the comment
        Set Rng = .Cells(2).Range
        With Rng
          .End = .End - 1
          .FormattedText = DocSrc.Comments(r).Scope.FormattedText
        End With
        'The comment itself
        Set Rng = .Cells(3).Range
        With Rng
          .End = .End - 1
          .FormattedText = DocSrc.Comments(r).Range.FormattedText
        End With
        'The comment author
        .Cells(4).Range.Text = DocSrc.Comments(r).Author
      End With
    Next
  End With
  .Activate
End With
Set DocSrc = Nothing: Set DocTgt = Nothing: Set Tbl = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
MsgBox "Finished creating comments document."
End Sub

jimmy12 · #4 05-15-2021, 12:58 AM

Hi both,

Thanks. I really appreciate your support.

I tried both options, but they didn't seem to work. @Macropod, the debugger flagged an issue at:

.Cells(1).Range.Text = DocSrc.Comments(n).Scope.Information(wdActiveEndPa geNumber)

macropod · #5 05-15-2021, 01:05 AM

Quote:

Originally Posted by jimmy12

@Macropod, the debugger flagged an issue at:

.Cells(1).Range.Text = DocSrc.Comments(n).Scope.Information(wdActiveEndPa geNumber)

That line is essentially what you already had:
.Cells(1).Range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPage Number)

Code corrected.

Guessed · #6 05-15-2021, 01:12 AM

I think Paul has solved the issue with the local formatting but there was a mix up with the r and n variables. His code doesn't bring across the paragraph style either. So using his lead, try this variant

Code:

Sub AnalyseComments()
  Dim oDoc As Document, oNewDoc As Document, oTable As Table
  Dim aCom As Comment, nCount As Long, n As Long, aRng As Range
  
  Set oDoc = ActiveDocument
  nCount = ActiveDocument.Comments.Count
  
  'Create a new document for the comments
  Set oNewDoc = Documents.Add(Template:=ActiveDocument.FullName)
  oNewDoc.Range.Delete
  
  'Insert a 4-column table for the comments
  With oNewDoc
    .Content = ""
    Set oTable = .Tables.Add(Range:=Selection.Range, NumRows:=nCount + 1, NumColumns:=4)
  End With
  
  With oTable.Rows(1)
    .Range.Font.Bold = True
    .Cells(1).Range.Text = "Page"
    .Cells(2).Range.Text = "Comment scope"
    .Cells(3).Range.Text = "Comment text"
    .Cells(4).Range.Text = "Author"
  End With
  
  'Get info from each comment from oDoc and insert in table
  For n = 1 To nCount
    Set aCom = oDoc.Comments(n)
    With oTable.Rows(n + 1)
      .Cells(1).Range.Text = aCom.Scope.Information(wdActiveEndPageNumber)      'Page number
      Set aRng = .Cells(2).Range
      With aRng
        .Style = aCom.Scope.Paragraphs(1).Style
        .End = .End - 1
        .FormattedText = aCom.Scope.FormattedText
      End With
      .Cells(3).Range.Text = aCom.Range.Text    'The comment itself
      .Cells(4).Range.Text = aCom.Author    'The comment author
    End With
  Next n
  
  oNewDoc.Activate
  MsgBox "Finished creating comments document."
  
  Set oDoc = Nothing
  Set oNewDoc = Nothing
  Set oTable = Nothing

End Sub

jimmy12 · #7 05-15-2021, 02:48 AM

Hi all,

I want to extend my thanks to you for your assistance. Really appreciated. I made a couple of quick amends to the coding as the debugger didn't quite like a particular line. This was the final code in the end:

oDoc As Document, oNewDoc As Document, oTable As Table
Dim aCom As Comment, nCount As Long, n As Long, aRng As Range

Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count

'Create a new document for the comments
Set oNewDoc = Documents.Add
oNewDoc.Range.Delete

'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add(Range:=Selection.Range, NumRows:=nCount + 1, NumColumns:=4)
End With

With oTable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
End With

'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
Set aCom = oDoc.Comments(n)
With oTable.Rows(n + 1)
.Cells(1).Range.Text = aCom.Scope.Information(wdActiveEndPageNumber) 'Page number
Set aRng = .Cells(2).Range
With aRng
.Style = aCom.Scope.Paragraphs(1).Style
.End = .End - 1
.FormattedText = aCom.Scope.FormattedText
End With
.Cells(3).Range.Text = aCom.Range.Text 'The comment itself
.Cells(4).Range.Text = aCom.Author 'The comment author
End With
Next n

oNewDoc.Activate
MsgBox "Finished creating comments document."

Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing

End Sub

Once again, thank you very much for your expertise and assistance.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA macro to change author name in tagged comments, then delete the tags	mjt	Word VBA	0	01-28-2021 08:48 AM
Macro to highlight and bolden specific text in Word Comments	PCUSER	Word VBA	1	09-22-2020 03:08 PM
Formula to delete but maintain counts after the maximum has been reached	wheddingsjr	Excel	2	01-03-2018 01:49 PM
Form won't maintain formatting	SBrant	Word	0	02-10-2011 10:29 AM
Maintain formatting while copying text from word, and pasting into a webpage.	kdogg121	Word	1	07-07-2009 02:50 AM