変奏現実

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

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