Extract All Memos in Excel

extract-memos.vb

Option Explicit

Sub ExtractMemos()
    Dim cmt As Comments
    Dim c As Comment
    Dim rp As Comment
    Dim sh As Worksheet
    Dim shex As Worksheet
    Dim exLine As Long
    ' cmt Comment[s]型 シート内のすべてのメモをコレクションとして格納
    ' c Comment型 cmt内のすべてのメモをループ回す用
    ' rp Comment型 ループ内で 各cの返信をコレクションとして取得
    ' sh Worksheet型 ブック内のすべてのシートをループで回す用
    ' shex Worksheet型 あるシートの横に作成したメモ出力用シートをセット
    ' exLine Long型 shex 内の次に書き込む行の行番号
    
    'ブック内の全シートをループ
    For Each sh In Worksheets
        Set cmt = sh.Comments
            
        'メモ出力用シート　同名シートがすでにあれば削除
        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
            shex.Cells(exLine, 3) = c.Text
            exLine = exLine + 1
        Next c '全メモループここまで
    Next sh '全シートループここまで
End Sub