【EXCEL VBA】指定ディレクトリ内Word文章毎の変更履歴一覧取得マクロ

指定したディレクトリ内にある複数のWord文書から、変更履歴（リビジョン）とコメントの一括リストをExcelへ取得するExcel VBAマクロです。他人の作成したWord文書の変更点をまとめて確認したい場合に役立ちます。

この記事でできること

指定フォルダ内のWord文書（.doc, .docx）を自動で開き、文書内の変更履歴とコメントをそれぞれExcelの別シートに一覧として書き出します。

前提条件・事前準備

• ExcelおよびWordがインストールされているWindows環境。
• ExcelのVBE（Visual Basic Editor）を開き、メニューの「ツール」＞「参照設定」から「Microsoft Word XX.X Object Library」にチェックを入れてください。

マクロのソースコード

以下のコードをExcelの標準モジュールに貼り付けて実行します。実行用のマクロは StartReporting です。

Option Explicit

Dim WdApp As Word.Application
Dim RptBook As Workbook

Sub StartReporting()
    ' 画面描画と警告を一時停止
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' レポート用ワークブックを作成し、シートを整える
    Set RptBook = Application.Workbooks.Add
    If RptBook.Sheets.Count >= 3 Then
        RptBook.Sheets(3).Delete
    End If
    
    RptBook.Sheets(2).Name = "コメント一覧"
    RptBook.Sheets(2).Range("$A$1").Value = "ファイル名"
    RptBook.Sheets(2).Range("$B$1").Value = "ページ"
    RptBook.Sheets(2).Range("$C$1").Value = "行"
    RptBook.Sheets(2).Range("$D$1").Value = "コメント作成者"
    RptBook.Sheets(2).Range("$E$1").Value = "コメント内容"
    
    RptBook.Sheets(1).Name = "変更履歴"
    RptBook.Sheets(1).Range("$A$1").Value = "ファイル名"
    RptBook.Sheets(1).Range("$B$1").Value = "ページ"
    RptBook.Sheets(1).Range("$C$1").Value = "行"
    RptBook.Sheets(1).Range("$D$1").Value = "変更種別"
    RptBook.Sheets(1).Range("$E$1").Value = "履歴作成者"
    RptBook.Sheets(1).Range("$F$1").Value = "履歴追加日"
    RptBook.Sheets(1).Range("$G$1").Value = "変更内容"
    
    ' Wordを起動
    Set WdApp = New Word.Application
    WdApp.DisplayAlerts = wdAlertsNone
    WdApp.Visible = True
    
    ' シート1のセルB1から対象フォルダパスを取得して処理を実行
    ' ※実行時はシート1のセルB1に検索対象のフォルダパス（例: C:\Docs\）を入力してください
    Report (ActiveWorkbook.Sheets(1).Range("$B$1").Text)
    
    ' Wordを終了
    WdApp.Quit
    Set WdApp = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "処理が完了しました。", vbInformation
End Sub

Sub Report(path As String)
    Dim wdDocName As String
    Dim curDoc As Word.Document
    
    If Right(path, 1) <> "\" Then path = path & "\"
    
    wdDocName = Dir(path & "*.doc*")
    
    Do While wdDocName <> ""
        Set curDoc = WdApp.Documents.Open(path & wdDocName)
        DoComments curDoc
        DoRevisions curDoc
        curDoc.Close False
        wdDocName = Dir()
    Loop
End Sub

Sub DoComments(cd As Word.Document)
    On Error Resume Next
    Dim x As Long
    Dim cm As Word.Comment
    Dim rw As Long
    
    rw = RptBook.Sheets("コメント一覧").Range("$A$1048576").End(xlUp).Row + 1
    
    For x = 1 To cd.Comments.Count
        Set cm = cd.Comments(x)
        RptBook.Sheets("コメント一覧").Range("$A$" & rw).Value = cd.Name
        RptBook.Sheets("コメント一覧").Range("$B$" & rw).Value = cm.Scope.Information(wdActiveEndAdjustedPageNumber)
        RptBook.Sheets("コメント一覧").Range("$C$" & rw).Value = cm.Scope.Information(wdFirstCharacterLineNumber)
        RptBook.Sheets("コメント一覧").Range("$D$" & rw).Value = cm.Author
        RptBook.Sheets("コメント一覧").Range("$E$" & rw).Value = cm.Range.Text
        rw = rw + 1
    Next x
End Sub

Sub DoRevisions(cd As Word.Document)
    On Error Resume Next
    Dim x As Long
    Dim oRev As Word.Revision
    Dim rw As Long
    Dim t As String
    
    rw = RptBook.Sheets("変更履歴").Range("$A$1048576").End(xlUp).Row + 1
    
    For x = 1 To cd.Revisions.Count
        Set oRev = cd.Revisions(x)
        Select Case oRev.Type
            Case wdNoRevision: t = "変更なし"
            Case wdRevisionConflict: t = "競合"
            Case wdRevisionDelete: t = "削除"
            Case wdRevisionDisplayField: t = "フィールド表示の変更"
            Case wdRevisionInsert: t = "挿入"
            Case wdRevisionParagraphNumber: t = "段落番号の変更"
            Case wdRevisionParagraphProperty: t = "段落のプロパティの変更"
            Case wdRevisionProperty: t = "プロパティの変更"
            Case wdRevisionReconcile: t = "解決された競合"
            Case wdRevisionReplace: t = "置換"
            Case wdRevisionSectionProperty: t = "セクションのプロパティの変更"
            Case wdRevisionStyle: t = "スタイルの変更"
            Case wdRevisionStyleDefinition: t = "スタイル定義の変更"
            Case wdRevisionTableProperty: t = "表のプロパティの変更"
            Case wdRevisionCellDeletion: t = "表のセルの削除"
            Case wdRevisionCellInsertion: t = "表のセルの挿入"
            Case wdRevisionCellMerge: t = "表のセルの結合"
            Case wdRevisionMovedFrom: t = "内容の移動元"
            Case wdRevisionMovedTo: t = "内容の移動先"
            Case Else: t = "その他"
        End Select
        
        RptBook.Sheets("変更履歴").Range("$A$" & rw).Value = cd.Name
        RptBook.Sheets("変更履歴").Range("$B$" & rw).Value = oRev.Range.Information(wdActiveEndAdjustedPageNumber)
        RptBook.Sheets("変更履歴").Range("$C$" & rw).Value = oRev.Range.Information(wdFirstCharacterLineNumber)
        RptBook.Sheets("変更履歴").Range("$D$" & rw).Value = t
        RptBook.Sheets("変更履歴").Range("$E$" & rw).Value = oRev.Author
        RptBook.Sheets("変更履歴").Range("$F$" & rw).Value = oRev.Date
        RptBook.Sheets("変更履歴").Range("$G$" & rw).Value = Left(oRev.Range.Text, 255)
        
        rw = rw + 1
    Next x
End Sub

使い方・実行手順

1. マクロを書き込んだExcelファイルの最初のシート（シート1）のセル B1 に、チェック対象のWord文書が保存されているフォルダパス（例: C:\MyDocs\）を入力します。
2. VBE画面またはマクロ実行画面から StartReporting を実行します。
3. 自動的にWordが起動し、指定フォルダ内の全Wordファイルを走査して新しいExcelブックに「変更履歴」と「コメント一覧」が出力されます。

注意事項

• 対象のWord文書にパスワードが設定されている場合、マクロが途中で停止することがあります。事前にパスワードを解除するか、アクセス可能な状態で実行してください。
• 文書量やファイル数が多い場合、処理に時間がかかることがあります。