- Joined
- Oct 18, 2022
- Messages
- 1
- Reaction score
- 0
Could someone help me please. I am new to VBA coding. The code below, I am having trouble getting it to populate the fourth column with the value from the cell with comments. Also, each time I run the code on a different worksheet, it adds the information in the same sheet called "comments". Thats fine, but I would like to know how to write a code that would copy the active sheet name and use it as a seperation title between each run of the macro.
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("A11")
.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
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("A11")
.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