Creating a Sheet of Comments - vba

Question

Caution, I am a novice.
Objective: To create a "Comments" sheet that includes all comments from the current sheet selected. Here is what my sheet looks like:
The way I want the sheet to look is:
The way the sheet actually appears is:
Essentially, I do not want to use the "Parent Address" for the "Comment In" column but rather the heading above the cell. For example, I do not want $A$2 but actually want it to refer to the heading "Responsible Party". My initial thought was that I could use named ranges but it proved to be out of my capabilities.
I am not a strong coder. Please keep this in mind.
The code is as follows:
Sub ExtractComments()
Dim ExComment As Comment
Dim i As Integer
Dim ws As Worksheet
Dim CS As Worksheet
Set CS = ActiveSheet
If ActiveSheet.Comments.Count = 0 Then Exit Sub
For Each ws In Worksheets
If ws.Name = "Comments" Then i = 1
Next ws
If i = 0 Then
Set ws = Worksheets.Add(After:=ActiveSheet)
ws.Name = "Comments"
Else: Set ws = Worksheets("Comments")
End If
For Each ExComment In CS.Comments
ws.Range("A1").Value = "Comment In"
ws.Range("B1").Value = "Comment By"
ws.Range("C1").Value = "Comment"
With ws.Range("A1:C1")
.Font.Bold = True
.Interior.Color = RGB(189, 215, 238)
.Columns.ColumnWidth = 20
End With
If ws.Range("A2") = "" Then
ws.Range("A2").Value = ExComment.Parent.Address
ws.Range("B2").Value = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
ws.Range("C2").Value = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
Else
ws.Range("A1").End(xlDown).Offset(1, 0) = ExComment.Parent.Address
ws.Range("B1").End(xlDown).Offset(1, 0) = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
ws.Range("C1").End(xlDown).Offset(1, 0) = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
End If
Next ExComment
End Sub
Thank you for your time.

Answer 1

It's definitely not bad from a novice :) Try this:
...
Else: Set ws = Worksheets("Comments")
End If
Dim iRow As Long ' you have a better control this way directly specifying the target cell
' header needs to written only once - out of loop
ws.Range("A1").Value = "Comment In"
ws.Range("B1").Value = "Comment By"
ws.Range("C1").Value = "Comment"
With ws.Range("A1:C1")
.Font.Bold = True
.Interior.Color = RGB(189, 215, 238)
.Columns.ColumnWidth = 20
End With
iRow = 2 ' first empty row
For Each ExComment In CS.Comments
ws.Cells(iRow, 1).Value = CS.Cells(1, ExComment.Parent.Column) ' value in 1st row of column of comment
ws.Cells(iRow, 2).Value = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
ws.Cells(iRow, 3).Value = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
iRow = iRow + 1
Next ExComment
End Sub

Answer 2

Just one change to add the header value, and shortened your code a little by working up from the bottom when adding comments, and remove some stuff from the loop.
Sub ExtractComments()
Dim ExComment As Comment
Dim i As Long
Dim ws As Worksheet
Dim CS As Worksheet
Set CS = ActiveSheet
If ActiveSheet.Comments.Count = 0 Then Exit Sub
For Each ws In Worksheets
If ws.Name = "Comments" Then i = 1
Next ws
If i = 0 Then
Set ws = Worksheets.Add(After:=ActiveSheet)
ws.Name = "Comments"
Else: Set ws = Worksheets("Comments")
End If
With ws
.Range("A1").Value = "Comment In"
.Range("B1").Value = "Comment By"
.Range("C1").Value = "Comment"
With .Range("A1:C1")
.Font.Bold = True
.Interior.Color = RGB(189, 215, 238)
.Columns.ColumnWidth = 20
End With
For Each ExComment In CS.Comments
.Range("A" & Rows.Count).End(xlUp)(2).Value = CS.Cells(1, ExComment.Parent.Column)
.Range("B" & Rows.Count).End(xlUp)(2).Value = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
.Range("C" & Rows.Count).End(xlUp)(2).Value = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
Next ExComment
End With
End Sub

Answer 3

use:
ws.Range("A2").Value = ExComment.Parent.End(xlUp).Value
so:
If ws.Range("A2") = "" Then
ws.Range("A2").Value = ExComment.Parent.End(xlUp).Value
ws.Range("B2").Value = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
ws.Range("C2").Value = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
Else
ws.Range("A1").End(xlDown).Offset(1, 0) = ExComment.Parent.End(xlUp).Value
ws.Range("B1").End(xlDown).Offset(1, 0) = Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1)
ws.Range("C1").End(xlDown).Offset(1, 0) = Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":"))
End If
while you could consider the following refactoring of your code
Sub ExtractComments()
If ActiveSheet.Comments.count = 0 Then Exit Sub
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets("Comments")
On Error GoTo 0
If ws Is Nothing Then
Set ws = Worksheets.Add(After:=ActiveSheet)
ws.Name = "Comments"
End If
Dim ExComment As Comment
With ws
With .Range("A1:C1")
.Value = Array("Comment In", "Comment By", "Comment")
.Font.Bold = True
.Interior.Color = RGB(189, 215, 238)
.Columns.ColumnWidth = 20
End With
For Each ExComment In ActiveSheet.Comments
.Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(, 3) = Array(ExComment.Parent.End(xlUp).Value, _
Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1), _
Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":")))
Next ExComment
End With
End Sub