Assist need with copy/paste cells for isolated notes macro

[ddutton]

The current code is isolating notes created. Need to copy paste two additional cells in the row where the note is located. Any assistance would be greatly appreciated. The data in the active sheet, columns "D" and "F" are where the "CONFIGURATION INSTANCE" & "SUPPORT GROUP" are located.

Sub LIST_NOTES()
Dim liComment As Comment
Dim i As Integer
Dim ws As Worksheet
Dim ComSh As Worksheet
Set ComSh = 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 = "AFTER ACTION REPORTING"
Else: Set ws = Worksheets("Comments")
End If

For Each liComment In ComSh.Comments
  ws.Range("A1").Value = "LOCATED IN CELL"
  ws.Range("B1").Value = "AUTHOR"
  ws.Range("C1").Value = "NOTE"
  ws.Range("D1").Value = "CONFIGURATION INSTANCE"
  ws.Range("E1").Value = "SUPPORT GROUP"
 
  With ws.Range("A1:E1")
    .Font.Bold = True
    .Interior.Color = RGB(189, 215, 238)
    .Columns.ColumnWidth = 40
  End With
  If ws.Range("A2") = "" Then
    ws.Range("A2").Value = liComment.Parent.Address
    ws.Range("B2").Value = Left(liComment.Text, InStr(1, liComment.Text, ":") - 1)
    ws.Range("C2").Value = Right(liComment.Text, Len(liComment.Text) - InStr(1, liComment.Text, ":"))
  Else
    ws.Range("A1").End(xlDown).Offset(1, 0) = liComment.Parent.Address
    ws.Range("B1").End(xlDown).Offset(1, 0) = Left(liComment.Text, InStr(1, liComment.Text, ":") - 1)
    ws.Range("C1").End(xlDown).Offset(1, 0) = Right(liComment.Text, Len(liComment.Text) - InStr(1, liComment.Text, ":"))
  End If
Next liComment
End Sub

 

[Fluff]

How about

    ws.Range("D2").Value = ComSh.Range("D" & liComment.Parent.Row)
    ws.Range("E2").Value = ComSh.Range("F" & liComment.Parent.Row)

 

[ddutton]

YES!.. thank you so much.. works perfectly.

 

[Fluff]

You're welcome & thanks for the feedback.