Here's a macro [main macro is 'commentslist' that lists the comments to a new
worksheet. Hopefully, you can re-work it to your needs.
'/================================================/
Sub CommentsList()
'Purpose of this VBA program is to find and list all comments
'in a Workbook
'
'For use with EXCEL 97 or higher
'
' Created 04/10/2002
'
' Gary L. Brown, Kinneson Corp
' (e-mail address removed)
'
Dim aryHiddensheets()
Dim bln1Sheet As Boolean
Dim iRow As Long, iColumn As Long
Dim dblLastRow As Long
Dim iCommentCount As Long
Dim i As Long
Dim x As Long, y As Long, iWorksheets As Long
Dim objOutputArea As Object, objCell As Object
Dim objComment As Object, objSheet As Object
Dim strResultsTableName As String
Dim strCellAddress As String, strExtraSheet As String
Dim strOrigCalcStatus As String
On Error Resume Next
strResultsTableName = "Comments_List"
bln1Sheet = False
'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select
'set workbook to manual
Application.Calculation = xlManual
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'redim array
ReDim aryHiddensheets(1 To iWorksheets)
'put hidden sheets in an array, then unhide the sheets
x = 0
y = 0
For Each objSheet In ActiveWorkbook.Sheets
y = y + 1
If objSheet.Visible <> True Then
x = x + 1
aryHiddensheets(x) = objSheet.name
objSheet.Visible = True
End If
Next objSheet
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
'Add worksheet if there is only one worksheet so error will not
' occur if the worksheet must be deleted. There HAS to be at
' least one worksheet in a workbook
If i = 1 Then
Worksheets.Add.Move after:=Worksheets(i)
i = ActiveWorkbook.Sheets.Count
strExtraSheet = Worksheets(2).name
bln1Sheet = True
End If
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).name) = UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
End If
Next
'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
'if an extra worksheet was added because there was only one worksheet
' in the original workbook, delete it now
If bln1Sheet Then
Application.DisplayAlerts = False
Sheets(strExtraSheet).Delete
Application.DisplayAlerts = True
bln1Sheet = True
End If
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Worksheet"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Address"
ActiveWorkbook.ActiveSheet.Range("C1").value = "Col"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Row"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Cell Value"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Comment"
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'Initialize row and column counts for putting info into
' strResultsTableName sheet
iRow = 1
iColumn = 0
'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize count variable
iCommentCount = 0
If ActiveWorkbook.ActiveSheet.name <> strResultsTableName Then
'Identify the cells with formulas and text/values in them
Set objComment = Nothing
'Establish cells with comments in them
On Error Resume Next
Set objComment = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
iCommentCount = objComment.Count
'if there is a comment
If iCommentCount <> 0 Then
'Process each cell with a value or text in it
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
For Each objCell In objComment
With objOutputArea
'put information into StrResultstablename Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
strCellAddress = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add _
Anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.name & _
Chr(39) & "!" & _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = _
funcCol(strCellAddress)
.Offset(iRow, iColumn + 3) = _
funcRow(strCellAddress)
.Offset(iRow, iColumn + 4) = " " & _
objCell.value
.Offset(iRow, iColumn + 5) = " " & _
objCell.Comment.Text
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
Next objCell
End If
End If
Next x
If IsEmpty(Range("A2")) Then
Application.DisplayAlerts = False 'turn warnings off
Application.ActiveSheet.Delete
'ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
MsgBox "No Comments where located in..." & vbCr & Chr(34) & _
Application.ActiveWorkbook.name & Chr(34), vbInformation + vbOKOnly,
"Warning..."
GoTo exit_Sub
End If
'format the worksheet
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 75
Columns("F:F").ColumnWidth = 100
Cells.Select
Cells.EntireColumn.AutoFit
Columns("F:F").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
Selection.WrapText = True
Cells.Select
Cells.EntireRow.AutoFit
Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), _
Order3:=xlAscending, HEADER:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Columns("A:F").VerticalAlignment = xlTop
Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
If dblLastRow + 100 <= 65000 Then
dblLastRow = dblLastRow + 100
End If
ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
' ActiveWorkbook.ActiveSheet.Range("A1").value = _
' dblLastRow & " Comment(s) found."
Application.ActiveSheet.Range("A1").Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & " Comment(s) found." & Chr(34)
Selection.Font.Bold = True
Range("A2").Select
'formatting printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlPortrait
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
End With
ActiveWindow.Zoom = 75
Application.Dialogs(xlDialogWorkbookName).Show
exit_Sub:
're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next
're-set to original calculation method
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select
End Sub
'/================================================/
Private Function funcCol(strAddress As String) As String
Dim i As Integer
For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcCol = Left(strAddress, i - 1)
Exit Function
End If
Next i
End Function
'===========================================
Private Function funcRow(strAddress As String) As String
Dim i As Integer
For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcRow = Right(strAddress, Len(strAddress) - i + 1)
Exit Function
End If
Next i
End Function
'================================================
