Export comments in Excel (with subprocedure)

exract-comments-w-subprocedure.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
    
        ' cmt に、そのシート内の全コメントを含むコレクションをセット
        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
            Call ExtractComment(c, shex, exLine)
            exLine = exLine + 1
            
            'コメントに返信があれば、そのコメントについた全返信をループ
            If c.Replies.Count > 0 Then
                For Each rp In c.Replies
                    Call ExtractComment(rp, shex, exLine)
                    exLine = exLine + 1
                Next rp  '返信ループここまで
            End If
        
        Next c '全コメントループここまで
    Next sh '全シートループここまで
End Sub

' CommentThreadedオブジェクトの内容を
' シートに書き出すサブプロシージャ
Sub ExtractComment(ObjComment As CommentThreaded, dest As Worksheet, Line As Long)
    ' エラートラップ
' .Parent.Addressプロパティを取得しようとしてエラー438が出れば、
    'このCommentThreadedオブジェクトは、親コメントではなく
    '返信であることを意味するため、セル番地ではなく「返信」と書き込む
    On Error GoTo Replies
        dest.Cells(Line, 1) = ObjComment.Parent.Address
    On Error GoTo 0
    GoTo Nextstep
    
Replies: '返信であった場合の処理
    If Err.Number = 438 Then
        dest.Cells(Line, 1) = "返信"
    Else
        On Error GoTo 0
        Stop
    End If
    Resume Nextstep
        
Nextstep:
    dest.Cells(Line, 2) = ObjComment.Author.Name
    dest.Cells(Line, 3) = ObjComment.Text
End Sub