Hi,
I have a word macro that reads through the file and extracts all comments to an Excel document. It works fine, but the problem is that any comment which has multiple lines in it e.g.
Start comment
---
Comment 1: this is a comment.
It continues on a separate line
---
End Comment
appears in a single cell in Excel, which I want it to, but instead of a newline I get two square boxes (which I can't replicate in here and so I've used [] to represent them.
Test 3 – the best test ever
It has multiple lines
In the comment and in the highlight
becomes
Test 3 – the best test ever [][] It has multiple lines[][] In the comment and in the highlight
Is there any way to replace these as part of the macro, so they are CR/LF inside the cell, as if we pressed ALT Return in Excel.
Macro Code for those who want to try it and see the problem is below, I'm passing in range.text to Cell(5)
Public Sub ExtractCommentsToNewExcel()
'Original source Macro created 2007 by Lene Fredborg, DocTools
'amended by Phil Thomas May 2012 www.code45.co.uk
'with help from Frosty at VBAExpress.com
'phil.thomas @ code45 . co. uk
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata to Excel
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
'Setup all the variables
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Dim strName As String
'Excel stuff starts here
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
'Setup intital values
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
'Check if document has any comments in it and if it does, then check this is what the user wants to do
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
'Turned on as recommendation from MSDN Technet article
Application.ScreenUpdating = True
'New Excel setup
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add 'create a new workbook
'Create Excel sheet headings
With xlWB.Worksheets(1)
' Create Heading
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "Ref"
.Cells(HeadingRow, 2).Formula = "Section"
.Cells(HeadingRow, 3).Formula = "Page"
.Cells(HeadingRow, 4).Formula = "Referenced Quote/Context"
.Cells(HeadingRow, 5).Formula = "Comment"
.Cells(HeadingRow, 6).Formula = "Reviewer Name"
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
'comment number
.Cells(n + HeadingRow, 1).Value = n
'call function to get section heading
.Cells(n + HeadingRow, 2).Value = fGetNearestParaTextStyledIn(oDoc.Comments
.Scope)
'Page number
.Cells(n + HeadingRow, 3).Value = oDoc.Comments.Scope.Information(wdActiveEndPageNumber)
' Text referenced
.Cells(n + HeadingRow, 4).Value = oDoc.Comments.Scope
'The comment
.Cells(n + HeadingRow, 5).Value = oDoc.Comments.Range.Text
'The comment author
.Cells(n + HeadingRow, 6).Value = oDoc.Comments.Author
Next n
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
'Tell them its finished
'oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
'-
' COMPLEX SEARCH METHOD:
' Uses the Find object (which is always faster) to search an array of style names
' and return the text of the paragraph nearest to the original range
'-
Public Function fGetNearestParaTextStyledIn(Optional rngOriginal As Range, _
Optional sStyleNames As String = "Heading 1|Heading 2|Heading 3", _
Optional bLookDown As Boolean = False, _
Optional bIncludeParagraphMark As Boolean = False) As String
Dim oDoc As Document
Dim aryStyleNames() As String
Dim colFoundRanges As Collection
Dim rngReturn As Range
Dim i As Integer
Dim sReturnText As String
Dim s1ReturnText As String
Dim s2ReturnText As String
Dim lDistance As Long
On Error GoTo l_err
'set a default if we didn't pass it
If rngOriginal Is Nothing Then
Set rngOriginal = Selection.Range.Duplicate
End If
'create a new instance of a collection
Set colFoundRanges = New Collection
'get our array of style names to look for
aryStyleNames = Split(sStyleNames, "|")
'loop through the array
For i = 0 To UBound(aryStyleNames)
'if you wanted to add additional styles, you could change the optional parameter, or
'pass in different values
Set rngReturn = fGetNearestParaRange(rngOriginal.Duplicate, aryStyleNames(i), bLookDown)
'if we found it in the search direction
If Not rngReturn Is Nothing Then
'then add it to the collection
colFoundRanges.Add rngReturn
End If
Next
'if we found anything in our collection, then we can go through it,
'and see which range is closest to our original range, depending on our search direction
If colFoundRanges.Count > 0 Then
'start with an initial return
Set rngReturn = colFoundRanges(1)
'and an initial distance value as an absolute number
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
'then go through the rest of them, and return the one with the lowest distance between
For i = 2 To colFoundRanges.Count
If lDistance > Abs(rngOriginal.Start - colFoundRanges(i).Start) Then
'set a new range
Set rngReturn = colFoundRanges(i)
'and a new distance test
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
End If
Next
'now get the text we're going to return
s1ReturnText = rngReturn.ListFormat.ListString
s2ReturnText = rngReturn.Text
sReturnText = s1ReturnText & " -" & s2ReturnText
'and whether to include the paragraph mark
If bIncludeParagraphMark = False Then
sReturnText = Replace(sReturnText, vbCr, "")
End If
End If
l_exit:
fGetNearestParaTextStyledIn = sReturnText
Exit Function
l_err:
'black box, so that any errors return an empty string sReturnText = ""
Resume l_exit
End Function
'-
'return the nearest paragraph range styled
'defaults to Heading 1
'NOTE: if searching forward, starts searching from the *beginning* of the passed range
' if searching backward, starts searching from the *end* of the passed range
'-
Public Function fGetNearestParaRange(rngWhere As Range, _
Optional sStyleName As String = "Heading 1", _
Optional bSearchForward As Boolean = False) As Range
Dim rngSearch As Range
On Error GoTo l_err
Set rngSearch = rngWhere.Duplicate
'if searching down, then start at the beginning of our search range
If bSearchForward Then
rngSearch.Collapse wdCollapseStart
'otherwise, search from the end
Else
rngSearch.Collapse wdCollapseEnd
End If
'find the range
With rngSearch.Find
.Wrap = wdFindStop
.Forward = bSearchForward
.Style = sStyleName
'if we found it, return it
If .Execute Then
Set fGetNearestParaRange = rngSearch
Else
Set fGetNearestParaRange = Nothing
End If
End With
l_exit:
Exit Function
l_err:
'black box - any errors, return nothing
Set rngSearch = Nothing
Resume l_exit
End Function
I have a word macro that reads through the file and extracts all comments to an Excel document. It works fine, but the problem is that any comment which has multiple lines in it e.g.
Start comment
---
Comment 1: this is a comment.
It continues on a separate line
---
End Comment
appears in a single cell in Excel, which I want it to, but instead of a newline I get two square boxes (which I can't replicate in here and so I've used [] to represent them.
Test 3 – the best test ever
It has multiple lines
In the comment and in the highlight
becomes
Test 3 – the best test ever [][] It has multiple lines[][] In the comment and in the highlight
Is there any way to replace these as part of the macro, so they are CR/LF inside the cell, as if we pressed ALT Return in Excel.
Macro Code for those who want to try it and see the problem is below, I'm passing in range.text to Cell(5)
Public Sub ExtractCommentsToNewExcel()
'Original source Macro created 2007 by Lene Fredborg, DocTools
'amended by Phil Thomas May 2012 www.code45.co.uk
'with help from Frosty at VBAExpress.com
'phil.thomas @ code45 . co. uk
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata to Excel
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
'Setup all the variables
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Dim strName As String
'Excel stuff starts here
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
'Setup intital values
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
'Check if document has any comments in it and if it does, then check this is what the user wants to do
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
'Turned on as recommendation from MSDN Technet article
Application.ScreenUpdating = True
'New Excel setup
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add 'create a new workbook
'Create Excel sheet headings
With xlWB.Worksheets(1)
' Create Heading
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "Ref"
.Cells(HeadingRow, 2).Formula = "Section"
.Cells(HeadingRow, 3).Formula = "Page"
.Cells(HeadingRow, 4).Formula = "Referenced Quote/Context"
.Cells(HeadingRow, 5).Formula = "Comment"
.Cells(HeadingRow, 6).Formula = "Reviewer Name"
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
'comment number
.Cells(n + HeadingRow, 1).Value = n
'call function to get section heading
.Cells(n + HeadingRow, 2).Value = fGetNearestParaTextStyledIn(oDoc.Comments
.Scope)'Page number
.Cells(n + HeadingRow, 3).Value = oDoc.Comments
.Scope.Information(wdActiveEndPageNumber)' Text referenced
.Cells(n + HeadingRow, 4).Value = oDoc.Comments
.Scope'The comment
.Cells(n + HeadingRow, 5).Value = oDoc.Comments
.Range.Text'The comment author
.Cells(n + HeadingRow, 6).Value = oDoc.Comments
.AuthorNext n
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
'Tell them its finished
'oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
'-
' COMPLEX SEARCH METHOD:
' Uses the Find object (which is always faster) to search an array of style names
' and return the text of the paragraph nearest to the original range
'-
Public Function fGetNearestParaTextStyledIn(Optional rngOriginal As Range, _
Optional sStyleNames As String = "Heading 1|Heading 2|Heading 3", _
Optional bLookDown As Boolean = False, _
Optional bIncludeParagraphMark As Boolean = False) As String
Dim oDoc As Document
Dim aryStyleNames() As String
Dim colFoundRanges As Collection
Dim rngReturn As Range
Dim i As Integer
Dim sReturnText As String
Dim s1ReturnText As String
Dim s2ReturnText As String
Dim lDistance As Long
On Error GoTo l_err
'set a default if we didn't pass it
If rngOriginal Is Nothing Then
Set rngOriginal = Selection.Range.Duplicate
End If
'create a new instance of a collection
Set colFoundRanges = New Collection
'get our array of style names to look for
aryStyleNames = Split(sStyleNames, "|")
'loop through the array
For i = 0 To UBound(aryStyleNames)
'if you wanted to add additional styles, you could change the optional parameter, or
'pass in different values
Set rngReturn = fGetNearestParaRange(rngOriginal.Duplicate, aryStyleNames(i), bLookDown)
'if we found it in the search direction
If Not rngReturn Is Nothing Then
'then add it to the collection
colFoundRanges.Add rngReturn
End If
Next
'if we found anything in our collection, then we can go through it,
'and see which range is closest to our original range, depending on our search direction
If colFoundRanges.Count > 0 Then
'start with an initial return
Set rngReturn = colFoundRanges(1)
'and an initial distance value as an absolute number
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
'then go through the rest of them, and return the one with the lowest distance between
For i = 2 To colFoundRanges.Count
If lDistance > Abs(rngOriginal.Start - colFoundRanges(i).Start) Then
'set a new range
Set rngReturn = colFoundRanges(i)
'and a new distance test
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
End If
Next
'now get the text we're going to return
s1ReturnText = rngReturn.ListFormat.ListString
s2ReturnText = rngReturn.Text
sReturnText = s1ReturnText & " -" & s2ReturnText
'and whether to include the paragraph mark
If bIncludeParagraphMark = False Then
sReturnText = Replace(sReturnText, vbCr, "")
End If
End If
l_exit:
fGetNearestParaTextStyledIn = sReturnText
Exit Function
l_err:
'black box, so that any errors return an empty string sReturnText = ""
Resume l_exit
End Function
'-
'return the nearest paragraph range styled
'defaults to Heading 1
'NOTE: if searching forward, starts searching from the *beginning* of the passed range
' if searching backward, starts searching from the *end* of the passed range
'-
Public Function fGetNearestParaRange(rngWhere As Range, _
Optional sStyleName As String = "Heading 1", _
Optional bSearchForward As Boolean = False) As Range
Dim rngSearch As Range
On Error GoTo l_err
Set rngSearch = rngWhere.Duplicate
'if searching down, then start at the beginning of our search range
If bSearchForward Then
rngSearch.Collapse wdCollapseStart
'otherwise, search from the end
Else
rngSearch.Collapse wdCollapseEnd
End If
'find the range
With rngSearch.Find
.Wrap = wdFindStop
.Forward = bSearchForward
.Style = sStyleName
'if we found it, return it
If .Execute Then
Set fGetNearestParaRange = rngSearch
Else
Set fGetNearestParaRange = Nothing
End If
End With
l_exit:
Exit Function
l_err:
'black box - any errors, return nothing
Set rngSearch = Nothing
Resume l_exit
End Function
