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

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，我建立了一些errormaker。

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 

感谢您的教育！