ワークシートの代わりにブック全体のマクロを作成する

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 

教育に感謝します！