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

Question

我在网上找到了一个要修改的宏，因此它将获取整个工作簿中的所有注释。

我知道CS元素是我要更改的元素。 但是，当我将其更改为workbook ，它不起作用。

我想我需要创建一个循环。

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

您可以尝试对代码进行此重构；

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

特此感谢＃user3598756。 我只是对其进行了少许修改，因此它还显示了标签名，并且在其中建立了一些错误提示器。

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

感谢您的教育！