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