Here's a slight modification of a sub I wrote a long time ago - I'm
sure it's not the most efficient:
Public Sub CommentsToNewSheetByColumn()
Dim rng As Range
Dim cell As Range
Dim myRow As Long
Dim addr As String
Dim nameStr As String
On Error Resume Next
nameStr = "Comments in " & ActiveSheet.Name
Application.DisplayAlerts = False
Sheets(Left(nameStr, 31)).Delete
Application.DisplayAlerts = True
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No " & nameStr
Else
With Worksheets.Add(After:=ActiveSheet)
.Name = Left(nameStr, 31)
With .Columns(2)
.ColumnWidth = 100
.WrapText = True
End With
With .Range("A1")
.Value = nameStr
.Font.Bold = True
.Font.Size = .Font.Size + 2
End With
With .Range("A3").Resize(1, 2)
.Value = Array("Cell", "Comment")
.Font.Bold = True
.Font.Underline = True
End With
myRow = 4
For Each cell In rng
addr = cell.Address(True, False)
.Cells(myRow, 1).Value = Right(" " & _
Left(addr, InStr(addr, "$") - 1) & _
Format(Mid(addr, InStr(addr, "$") + 1), _
"00000"), 7)
.Cells(myRow, 2).Value = cell.Comment.Text
myRow = myRow + 1
Next cell
.Cells(4, 1).Sort _
Key1:=.Cells(4, 1), _
Order1:=xlAscending, _
Header:=xlYes
For Each cell In .Range("A4:A" & _
Range("A" & Rows.Count).End(xlUp).Row)
cell.Value = Range(cell.Value).Address(0, 0)
Next cell
End With
End If
End Sub
