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

「RevisionCheck.zip」をダウンロード

msdnのサンプルを参考にした、指定ディレクトリ内Word文章毎の変更履歴一覧取得マクロ

他人の作ったWord文章のどこが変わったのか一括でチェックする時を考えて作成

■ソース（事前に参照設定でMicrosoft Word XX.X Object Library をチェックする。）

Option Explicit
Dim WdApp As Word.Application
Dim RptBook As Workbook

Sub StartReporting()
   ‘Turn alerts off.
   Application.DisplayAlerts = False
   ‘Turn screen updating off.
   Application.ScreenUpdating = False
   ‘Create the Report Workbook and set up the worksheets.
   Set RptBook = Application.Workbooks.Add
   RptBook.Sheets(3).Delete
   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 = "変更内容"
   
   
   ‘Open Word and make it visible.
    Set WdApp = New Word.Application
    WdApp.DisplayAlerts = wdAlertsNone
    WdApp.Visible = True
   ‘Start the reporting loop. For this example, you get the path
   ‘where the docs are stored from cell B1.
   Report (Workbooks("RevisionCheck.xlsm").Sheets(1).Range("$b$1").Text)
   ‘Close Word.
   WdApp.Quit
   Set WdApp = Nothing
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

Sub Report(path As String)
    Dim wdDoc As String
    Dim curDoc As Word.Document
    ‘Get first document in directory
    wdDoc = Dir(path & "\*.doc*")
    ‘Loop until we don’t have anymore documents in the directory
   Do While wdDoc <> ""
      ‘Open the document
      Set curDoc = WdApp.Documents.Open(path & "\" & wdDoc)
      ‘Get comments
      DoComments curDoc
      ‘Get revisions
      DoRevisions curDoc
      ‘Close the document
      curDoc.Close
      ‘Get the next document
      wdDoc = Dir()
   Loop
End Sub

Sub DoComments(cd As Word.Document)
   On Error Resume Next
   Dim x As Integer
   Dim cm As Word.Comment
   Dim rw As Integer

   ‘Find the last row in the comments worksheet. Enumerating in
   ‘reverse is common practice in case there are blank rows (this
   ‘should not be the case here).
   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

   rw = rw + 1
   Next x
End Sub

Sub DoRevisions(cd As Word.Document)
   On Error Resume Next
   Dim x As Integer
   Dim oRev As Revision
   Dim rw As Integer
   Dim t As String

   ‘Find the last row in the revisions worksheet. Enumerating in
   ‘reverse is common practice in case there are blank rows (this
   ‘should not be the case here).
  rw = RptBook.Sheets("変更履歴").Range("$a$1048576").End(xlUp).Row + 1
   ‘Use a For Next loop with Revisions.Count instead
   ‘of a ForEach because revisions can be nested.
   For x = 1 To cd.Revisions.Count
      Set oRev = cd.Revisions(x)
      ‘This is the type of the Revision.
      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 = "内容の移動先"
      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 = Mid(oRev.Range, 1, 255) ‘変更内容

      rw = rw + 1
   Next x

End Sub

Private Sub CommandButton1_Click()
    Call StartReporting
End Sub