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。我只是稍微修改了它，所以它也显示了tabname，我建立了一些错误制作者。

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

感谢您的教育！

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

2 个答案: