今度はWORD文書のコメントの頁番号を列挙するマクロです。
EXCELのワークシートの「コメント行」セル名に「コメント」「コメント対象」「コメント頁番号」の列を追加して使用します。
コメントをワークシートに転記するマクロの内容は赤字頁番号（）をコピってこんな感じに
Public Sub コメント字頁番号検索()
On Error GoTo err1
'初期化
Dim wordApp As Word.Application
Set wordApp = CreateObject("Word.Application")
Dim コメントの開始行 As Long
コメントの開始行 = ActiveSheet.Range("タイトル行").row + 1
Dim コメントの列 As Long
コメントの列 = ActiveSheet.Range("タイトル行").Find("コメント").Column
Dim コメント対象の列 As Long
コメント対象の列 = ActiveSheet.Range("タイトル行").Find("コメント対象").Column
Dim 頁番号の列 As Long
On Error Resume Next
Err.Clear
頁番号の列 = ActiveSheet.Range("タイトル行").Find("コメント頁番号").Column
If Err.Number <> 0 Then
頁番号の列 = ActiveSheet.Range("タイトル行").Find("頁番号").Column
End If
'検索対象のWORD文書を開く
Dim wordFname As String
wordFname = 検索対象のWORD文書名を調べる
Dim wordDoc As Word.document
Set wordDoc = 検索対象のWORD文書を開く(wordApp, wordFname)
If TypeName(wordDoc) <> "Nothing" Then
Dim row As Long
row = コメントの開始行
wordDoc.ActiveWindow.Selection.Start = 0
wordDoc.ActiveWindow.Selection.End = 0
Dim コメント As Word.Comment
Dim 順番 As Integer
順番 = 1
Do While (コメント検索(wordDoc, 順番, コメント))
Dim コメント対象テキスト As String
コメント対象テキスト = コメント.Range.text
コメント対象テキスト = Replace(コメント対象テキスト, vbCr, "")
コメント対象テキスト = Replace(コメント対象テキスト, vbLf, "")
コメント対象テキスト = Trim(コメント対象テキスト)
If コメント対象テキスト <> "" Then
'コメント
ActiveSheet.Cells(row, コメントの列).Value = コメント.Range.text
'コメントの対象テキスト
コメント.Scope.Copy
ActiveSheet.Cells(row, コメント対象の列).Select
ActiveSheet.Paste
Dim pasteRows As Integer
pasteRows = Selection.Count
Dim st, ed
st = コメント.Scope.Start
ed = コメント.Scope.End
Dim 開始頁番号 As Integer
wordDoc.ActiveWindow.Selection.Start = st
wordDoc.ActiveWindow.Selection.End = st
開始頁番号 = wordDoc.ActiveWindow.Selection.Information(wdActiveEndAdjustedPageNumber)
Dim 終了頁番号 As Integer
wordDoc.ActiveWindow.Selection.Start = ed
wordDoc.ActiveWindow.Selection.End = ed
終了頁番号 = wordDoc.ActiveWindow.Selection.Information(wdActiveEndAdjustedPageNumber)
'右セルに頁番号を書き込む
Dim 頁番号説明文 As String
If 開始頁番号 <> 終了頁番号 Then
ActiveSheet.Cells(row, 頁番号の列).Value = 開始頁番号 & "～" & 終了頁番号 & "頁"
Else
ActiveSheet.Cells(row, 頁番号の列).Value = 開始頁番号 & "頁"
End If
row = row + pasteRows
End If
Loop
End If
exit1:
Call MSWORDをそのまま閉じる(wordApp)
Exit Sub
err1:
MsgBox Err.Description
GoTo exit1
End Subコメント検索は、順序の順にコメントを引き渡し、無くなったらFalseを返す様にしました。
パラメータのByRef指定を使って順序とコメントの内容を更新する方法は余り使わなくなった手法かもしれません。
Private Function コメント検索(ByRef wordDoc As Word.document, ByRef 順番 As Integer, ByRef コメント As Word.Comment) As Boolean
With wordDoc.Comments
If 順番 > .Count Then
コメント検索 = False
Exit Function
End If
Set コメント = wordDoc.Comments(順番)
順番 = 順番 + 1
End With
コメント検索 = True
End Function実際には、コメント検索やワークシートに【返信(Replies)】と【解決(Done)】の処理があった方が使い道がありそうですけどね。