Export comments in Excel

exract-comments.vb

Option Explicit

Sub ExtractComments()
    Dim cmt As CommentsThreaded
    Dim c As CommentThreaded
    Dim rp As CommentThreaded
    Dim sh As Worksheet
    Dim shex As Worksheet
    Dim exLine As Long
    ' cmt Comment[s]Threaded型 シート内のすべてのコメントをコレクションとして格納
    ' c CommentThreaded型 cmt内のすべてのコメントをループ回す用
    ' rp CommentThreaded型 ループ内で 各cの返信をコレクションとして取得
    ' sh Worksheet型 ブック内のすべてのシートをループで回す用
    ' shex Worksheet型 あるシートの横に作成したコメント出力用シートをセット
    ' exLine Long型 shex 内の次に書き込む行の行番号
    
    'ブック内の全シートをループ
    For Each sh In Worksheets
        Set cmt = sh.CommentsThreaded
            
        'コメント出力用シート　同名シートがすでにあれば削除
        On Error Resume Next
        Application.DisplayAlerts = False
            Sheets(sh.Name & "_comments").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        'コメント出力用シート作成
        Set shex = Worksheets.Add(After:=sh)
        shex.Name = sh.Name & "_comments"
        
        shex.Range("A1") = "セル"
        shex.Range("B1") = "作成者"
        shex.Range("C1") = "内容"
        exLine = 2
        
        'シート内の全コメントをループ
        For Each c In cmt
            shex.Cells(exLine, 1) = c.Parent.Address
            shex.Cells(exLine, 2) = c.Author.Name
            shex.Cells(exLine, 3) = c.Text
            exLine = exLine + 1
            
            'コメントに返信があれば、そのコメントについた全返信をループ
            If c.Replies.Count > 0 Then
                For Each rp In c.Replies
                    shex.Cells(exLine, 1) = "返信" '返信には.Parent.Addressが存在しないためこのように
                    shex.Cells(exLine, 2) = rp.Author.Name
                    shex.Cells(exLine, 3) = rp.Text
            exLine = exLine + 1
                Next rp  '返信ループここまで
            End If
        
        Next c '全コメントループここまで
    Next sh '全シートループここまで
End Sub