Add Comments to Word

[Jeff Mackeny]

I have the following code to copy out all Comments on the active sheet to
word, ok first of all I don't need the $ before the column and row, next is
it possible to also list a value from a specific column, in other words my
column B is always a list of people so if I add a comment on E4 it should
add the value of B4, if I have a comment on H8 it should add B8 and so on,
perhaps maybe I could be done on the other code I have which copies all
comments to a new sheet, the only drawback with that second code is that I'd
rather open a new excel workbook Vs inserting a new sheet.

CODE ONE
Sub CopyCommentsToWord()

Dim cmt As Comment
Dim WdApp As Object

On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WdApp = CreateObject("Word.Application")
End If

With WdApp
.Visible = True
.Documents.Add DocumentType:=0

For Each cmt In ActiveSheet.Comments
.Selection.TypeText cmt.Parent.Address _
& vbTab & cmt.Text
.Selection.TypeParagraph
Next
End With

Set WdApp = Nothing

End Sub
----------------------------------------------------------------------------
-------
CODE TWO
Sub ShowCommentsAllSheets()
'modified from code
'posted by Dave Peterson 2003-05-16
Application.ScreenUpdating = False

Dim commrange As Range
Dim mycell As Range
Dim ws As Worksheet
Dim newwks As Worksheet
Dim i As Long

Set newwks = Worksheets.Add

newwks.Range("A1:E1").Value = _
Array("Sheet", "Address", "Name", "Value", "Comment")

For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0

If commrange Is Nothing Then
'do nothing
Else

i = newwks.Cells(Rows.Count, 1).End(xlUp).Row

For Each mycell In commrange
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = ws.Name
.Cells(i, 2).Value = mycell.Address
.Cells(i, 3).Value = mycell.Name.Name
.Cells(i, 4).Value = mycell.Value
.Cells(i, 5).Value = mycell.Comment.Text
End With
Next mycell
End If
Set commrange = Nothing
Next ws

'format cells for no wrapping, remove line break
newwks.Cells.WrapText = False
newwks.Columns("E:E").Replace What:=Chr(10), _
Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

End Sub

 

[Tom Ogilvy]

CODE ONE
Sub CopyCommentsToWord()

Dim cmt As Comment
Dim WdApp As Object

On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WdApp = CreateObject("Word.Application")
End If

With WdApp
.Visible = True
.Documents.Add DocumentType:=0

For Each cmt In ActiveSheet.Comments
.Selection.TypeText cmt.Parent.Address (0,0) _
& vbTab & Cells(cmt.parent.row,2).Value & vbTab & cmt.Text
.Selection.TypeParagraph
Next
End With

Set WdApp = Nothing

End Sub