凡人も語りたい

VBAに関すことや日々考えている事柄について投稿しようと思っています。

セルコメントがあるセル番地とコメント内容を抽出するサブルーチン

セルコメントを別シートセル番地と内容を抽出し、セルコメントを削除するコード作ったので、備忘録ついでに投稿します。
※補足※サブルーチンのためこのコードのみでは動作しません。万が一コピペして利用するようなことがあればご注意ください。

コメントのセル番地と内容を抽出し、新規シートへ転記する
Sub CommentOut(wsInput As Worksheet)
    Dim trg As Range
    Dim arr() As Variant
    Dim cnt As Long
    ReDim arr(1 To 2, 1 To 1) As Variant

'    コメントセルに関する情報を二次元配列へ格納
    For Each trg In wsInput.Range("A1").CurrentRegion
        If TypeName(trg.Comment) = "Comment" Then
            cnt = cnt + 1
            ReDim Preserve arr(1 To 2, 1 To cnt)
            arr(1, cnt) = trg.Address
            arr(2, cnt) = trg.Comment.Text
'            trg.Comment.Delete
        End If
    Next
'    コメント抽出用シートの作成
    Worksheets.Add after:=Sheets(Sheets.Count)
    Dim wsOutput As Worksheet
    Set wsOutput = Sheets(Sheets.Count)
    wsOutput.Name = "抽出コメント"
    wsOutput.Range("A1:B" & cnt) = WorksheetFunction.Transpose(arr)
End Sub
メッセージボックスで検索セル数、コメント付きセル数、セルコメント割合を集計・表示する
Sub CommentsCounter(wsInput As Worksheet)
    Dim trg As Range, cnt(1) As Long, Ans As Long
    For Each trg In wsInput.Range("A1").CurrentRegion
        cnt(0) = cnt(0) + 1
        If TypeName(trg.Comment) = "Comment" Then
            cnt(1) = cnt(1) + 1
        End If
    Next
    Ans = cnt(1) * 100 / cnt(0)
    
    MsgBox " 全検索セル数:" & cnt(0) & vbLf & "内 コメント付:" & cnt(1) & vbLf & "  コメント率:" & Ans & "%"
End Sub