Wordファイルの修正履歴箇所のみ文字カウントする方法

以下のマクロをWordのVBAエディタに貼り付けて実行

Sub CountRevisionChars()
    Dim doc As Document
    Dim rev As Revision
    Dim totalChars As Long
    Dim insertChars As Long
    Dim deleteChars As Long

    Set doc = ActiveDocument
    totalChars = 0
    insertChars = 0
    deleteChars = 0

    For Each rev In doc.Revisions
        ' 挿入された文字のカウント
        If rev.Type = wdRevisionInsert Then
            insertChars = insertChars + Len(rev.Range.Text)
        End If
        ' 削除された文字のカウント
        If rev.Type = wdRevisionDelete Then
            deleteChars = deleteChars + Len(rev.Range.Text)
        End If
    Next rev

    totalChars = insertChars + deleteChars

    MsgBox "■ 修正履歴の文字数カウント結果" & vbCrLf & _
           "挿入文字数: " & insertChars & " 文字" & vbCrLf & _
           "削除文字数: " & deleteChars & " 文字" & vbCrLf & _
           "合計: " & totalChars & " 文字"
End Sub

VBAの起動手順

  1. Alt + F11 でVBAエディタを開く
  2. 挿入 → 標準モジュール をクリック
  3. 上記コードを貼り付け
  4. F5 で実行

英語の単語数(1バイト文字)もカウントしたい場合のVBAコード

Sub CountRevisionCharsAndWords()
    Dim doc As Document
    Dim rev As Revision
    Dim insertChars As Long
    Dim deleteChars As Long
    Dim insertWords As Long
    Dim deleteWords As Long

    Set doc = ActiveDocument

    For Each rev In doc.Revisions
        ' 挿入のカウント
        If rev.Type = wdRevisionInsert Then
            insertChars = insertChars + Len(rev.Range.Text)
            insertWords = insertWords + rev.Range.Words.Count
        End If
        ' 削除のカウント
        If rev.Type = wdRevisionDelete Then
            deleteChars = deleteChars + Len(rev.Range.Text)
            deleteWords = deleteWords + rev.Range.Words.Count
        End If
    Next rev

    MsgBox "■ Revision Count Results" & vbCrLf & _
           "--- Insertions ---" & vbCrLf & _
           "Characters: " & insertChars & vbCrLf & _
           "Words:      " & insertWords & vbCrLf & _
           "--- Deletions ---" & vbCrLf & _
           "Characters: " & deleteChars & vbCrLf & _
           "Words:      " & deleteWords & vbCrLf & _
           "--- Total ---" & vbCrLf & _
           "Characters: " & (insertChars + deleteChars) & vbCrLf & _
           "Words:      " & (insertWords + deleteWords)
End Sub

出力イメージ

■ Revision Count Results
— Insertions —
Characters: 120
Words:      24
— Deletions —
Characters: 85
Words:      17
— Total —
Characters: 205
Words:      41

スペースを除いた文字数が欲しい場合

Len() の部分を以下に変更するとスペースを除外できます。

Len(Replace(rev.Range.Text, " ", ""))

コメント

タイトルとURLをコピーしました