使宏適用於整個工作簿而不是工作表

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 

感謝您的教育！