使宏适用于整个工作簿而不是工作表

Question

I found a macro online, that I would like to modify, so it will grab all the comments from my entire workbook.

I understand that the CS element is the element I want to change. But when I change it to workbook , it doesn't work.

I think I need to create a loop.

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

Answer 1

you could try this refactoring of your code;

Option Explicit

Sub ExtractComments()
    Dim ws As Worksheet
    Dim commentsSht As Worksheet

    Set commentsSht = GetOrSetWorksheet("Comments")
    With commentsSht
        .Cells.ClearContents
        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
    End With

    For Each ws In Worksheets
        If ws.Comments.Count > 0 Then ProcessComments ws, commentsSht
    Next ws
End Sub

Sub ProcessComments(ws As Worksheet, commentsSht As Worksheet)
    Dim ExComment As Comment

    With commentsSht
        For Each ExComment In ws.Comments
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).value = Array(ExComment.Parent.Address, _
                                                                                  Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1), _
                                                                                  Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":")))
        Next ExComment
    End With
End Sub

Function GetOrSetWorksheet(shtName) As Worksheet
    On Error Resume Next
    Set GetOrSetWorksheet = Worksheets(shtName)
    If GetOrSetWorksheet Is Nothing Then
        Set GetOrSetWorksheet = Worksheets.add(After:=ActiveSheet)
        GetOrSetWorksheet.Name = shtName
    End If
End Function

Answer 2

Hereby my code, thanks to #user3598756. I just slightly modified it, so it also displays tabname and i builded some errormaker into it.

Public Sub Get_Comments()
    On Error GoTo ErrMsg

    Dim ws As Worksheet
    Dim commentsSht As Worksheet

    Set commentsSht = GetOrSetWorksheet("Comments")
    With commentsSht
        .Cells.ClearContents
        With .Range("A1:D1")
            .Value = Array("Comment in Tab", "Cellref", "Comment By", "Comment")
            .Font.Bold = True
            .Interior.Color = 10092543
            .Columns("A").ColumnWidth = 20
            .Columns("B").ColumnWidth = 15
            .Columns("C").ColumnWidth = 20
            .Columns("D").ColumnWidth = 75
        End With
    End With

    For Each ws In Worksheets
        If ws.Comments.Count > 0 Then ProcessComments ws, commentsSht
    Next ws
Exit Sub

ErrMsg:
MsgBox prompt:="Free feedback your doing something wrong" & Chr(13) & Chr(13) & "Free feedback your doing something wrong"

End Sub

Sub ProcessComments(ws As Worksheet, commentsSht As Worksheet)
    On Error GoTo ErrMsg
    Dim ExComment As Comment

    With commentsSht
        For Each ExComment In ws.Comments
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value = _
            Array(ExComment.Parent.Worksheet.Name, _
            ExComment.Parent.Address, _
            Left(ExComment.Text, InStr(1, ExComment.Text, ":") - 1), _
            Right(ExComment.Text, Len(ExComment.Text) - InStr(1, ExComment.Text, ":") - 1))
        Next ExComment
    End With
Exit Sub

ErrMsg:
MsgBox prompt:="Free feedback your doing something wrong" & Chr(13) & Chr(13) & "Free feedback your doing something wrong"

End Sub

Function GetOrSetWorksheet(shtName) As Worksheet
    On Error Resume Next
    Set GetOrSetWorksheet = Worksheets(shtName)
    If GetOrSetWorksheet Is Nothing Then
        Set GetOrSetWorksheet = Worksheets.Add(After:=ActiveSheet)
        GetOrSetWorksheet.Name = shtName
    End If
End Function

Thanks for the education!