Once again, while helping out in a forum, I developed a simple little sub routine I thought I’d share with everyone in the hopes it could serve others. You simply supply the name of a worksheet and the sub will then create a new worksheet in which it will then generate a table listing all the comments from the specified worksheet.
'---------------------------------------------------------------------------------------
' Procedure : Excel_ExtractComments
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Extracts all the comments from the specified worksheet and generates a
' table listing all the comments found on a newly created sheet named
' 'Comment List'
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sWorkSheetName Name of the worksheet to extract all the comments from
'
' Usage:
' ~~~~~~
' Excel_ExtractComments "Sheet1"
' Call Excel_ExtractComments("WIP")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-09-10 Initial Release, Forum Help
'---------------------------------------------------------------------------------------
Public Sub Excel_ExtractComments(sWorkSheetName As String)
Dim WSSrc As Excel.Worksheet
Dim WSDest As Excel.Worksheet
Dim oCom As Excel.Comment
Dim i As Long
Dim j As Long
Const sDestSheetName = "Comment List"
Application.DisplayAlerts = False
'Ensure we start with a new fresh result sheet
On Error Resume Next
Set WSDest = Sheets(sDestSheetName)
If Err.Number = 0 Then
WSDest.Delete
Else
Err.Clear
End If
'Try and set a variable to the sheet from which to extract the comments from
Set WSSrc = Sheets(sWorkSheetName) 'ActiveSheet
If Err.Number <> 0 Then
MsgBox "The specified sheet '" & sWorkSheetName & "' could not be found." & _
" Please verify the sheet name and try again.", _
vbInformation Or vbOKOnly, "Sheet Not Found"
GoTo Error_Handler_Exit
End If
On Error GoTo Error_Handler
'Create a sheet to build our extracted data/results on
Set WSDest = Worksheets.Add
WSDest.Name = sDestSheetName
'Build a summary title/date/total comments
WSDest.Range("A1:D1").Merge True
WSDest.Range("A2:D2").Merge True
WSDest.Range("A3:D3").Merge True
WSDest.Cells(1, 1).Value = "List of comments found on Sheet '" & sWorkSheetName & "'"
WSDest.Cells(2, 1).Value = "Report generated " & Format(Now(), "yyyy-mmm-dd hh:nn")
WSDest.Cells(3, 1).Value = WSSrc.Comments.Count & " comments extracted"
'Build our data table
'Build a header
i = 5
WSDest.Cells(i, 1).Value = "No."
WSDest.Cells(i, 2).Value = "Cooment Address"
WSDest.Cells(i, 3).Value = "Comment By"
WSDest.Cells(i, 4).Value = "Comment"
With WSDest.Range(WSDest.Cells(i, 1), _
WSDest.Cells(i, 4))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
'Get the actual comments
For Each oCom In WSSrc.Comments
i = i + 1
j = j + 1
'Sequential number
WSDest.Cells(i, 1).Value = j
'Cell address where the comment was located
WSDest.Cells(i, 2).Value = oCom.Parent.Address
'Hyperlink back to the originating cell
WSDest.Cells(i, 2).Hyperlinks.Add Anchor:=WSDest.Cells(i, 2), Address:="", _
SubAddress:=CStr(WSSrc.Name & "!" & oCom.Parent.Address)
sComm = oCom.Text 'Full comment (Author and comment)
'Author of the comment
WSDest.Cells(i, 3).Value = Left(sComm, InStr(1, sComm, ":") - 1)
sComm = Mid(sComm, InStr(1, sComm, ":") + 1)
'Remove any leading carriage returns
Do While Left(sComm, 1) = Chr(10)
sComm = Mid(sComm, 2)
Loop
'Comment
WSDest.Cells(i, 4).Value = sComm
Next oCom
'A little formatting to make things pretty
WSDest.Columns("A:D").EntireColumn.AutoFit
WSDest.Rows("6:" & i).EntireRow.AutoFit
WSDest.Range("A1").Select 'Return to the top of the page
Error_Handler_Exit:
On Error Resume Next
Application.DisplayAlerts = True
If Not oCom Is Nothing Then Set oCom = Nothing
If Not WSDest Is Nothing Then Set WSDest = Nothing
If Not WSSrc Is Nothing Then Set WSSrc = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Excel_ExtractComments" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
Hi, the code works perfectly. Could you please advise what changes to be made in order to extract comments from the workbook instead of just one sheet.