PDA

View Full Version : HLEP!! I need help modifying this code.



Cavon
10-17-2022, 10:47 AM
Sub ExtractComments()
Dim ExComment As Comment
Dim i As Integer
Dim aNumber 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"
ws.Range("D1").Value = "DownTime"
With ws.Range("A1:D1")
.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, ":"))
ws.Range("D2").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

I need to modify so that it also extracts the value from the cell with comments and place that value in the newly made column called downtime.
Can someone help me please?