Office関連

文書内の単語を単語ごとにカウントするWordマクロ

Wordsコレクションを使って文書内の単語を列挙し、各単語がそれぞれいくつあるのかをカウントするWordマクロで、結果は新しい文書に表形式で出力します。

カウントを行う「CntWord」関数内の検索条件を変更すれば得られる結果も変更されます。

Option Explicit

Public Sub CountDocumentWords()
'文書内の単語を単語ごとにカウントする
  Dim doc As Word.Document
  Dim w As Word.Range
  Dim dic As Object
  Dim itm As Variant
  Dim i As Long
  
  i = 2 '初期化
  Application.ScreenUpdating = False
  Set doc = ActiveDocument
  Set dic = CreateObject("Scripting.Dictionary")
  For Each w In doc.Words
    '単語が重複しないようにDictionaryオブジェクトを使用
    If Not dic.Exists(w.Text) Then
      dic.Add w.Text, w.Text
    End If
  Next
  With Application.Documents.Add
    With .Tables.Add(.Range, 1, 3)
      .Cell(1, 1).Range.Text = ""
      .Cell(1, 2).Range.Text = "単語"
      .Cell(1, 3).Range.Text = "個数"
      For Each itm In dic.Items
        .Rows.Add
        .Cell(i, 1).Range.Text = i - 1
        .Cell(i, 2).Range.Text = itm
        .Cell(i, 3).Range.Text = CntWord(doc, itm)
        i = i + 1
      Next
      'テーブルの装飾
      .AutoFitBehavior wdAutoFitContent
      .Borders.InsideLineStyle = wdLineStyleSingle
      .Borders.OutsideLineStyle = wdLineStyleSingle
      .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      With .Rows(1).Shading
        .Texture = wdTextureNone
        .ForegroundPatternColor = wdColorAutomatic
        .BackgroundPatternColor = 16751103
      End With
    End With
  End With
  Set dic = Nothing
  Set doc = Nothing
  Application.ScreenUpdating = True
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Function CntWord(ByVal doc As Word.Document, ByVal txt As String) As String
'単語数をカウントする
  Dim tmp As String
  Dim ret As String
  Dim r As Word.Range
  Dim cnt As Long
  
  ret = "": cnt = 0 '初期化
  tmp = Replace$(txt, " ", "")
  tmp = Replace$(tmp, " ", "")
  tmp = Replace$(tmp, vbCrLf, "")
  tmp = Replace$(tmp, vbCr, "")
  tmp = Replace$(tmp, vbLf, "")
  If Len(tmp) > 0 Then
    Set r = doc.Range(0, 0)
    With r.Find
      '検索条件は適宜変更
      .ClearFormatting
      .ClearAllFuzzyOptions
      .Text = txt
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchByte = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = False
      Do While .Execute
        cnt = cnt + 1
      Loop
    End With
    Set r = Nothing
    ret = CStr(cnt)
  End If
  CntWord = ret
End Function

関連記事

  1. Office関連

    [VBA]ユーザーフォーム上のコンボボックスでオートコンプリート機能を実装する方法

    MSDNフォーラムに「ユーザーフォーム上のコンボボックスで、任意の文字…

  2. Office アドイン

    [Officeアドイン]ワークシートで選択範囲を変更したときに発生するイベント

    ワークシート上で選択範囲の変更を検知する際、VBAでは通常「Works…

  3. Office関連

    モヤさまのショウ君にいろいろ喋らせるVBAマクロ(2)

    前回に引き続き、HOYAサービス株式会社様が公開されている「Voice…

  4. アイコン一覧

    Office 2013 アイコン一覧(V)

    ・Office 2013 アイコン一覧 NUM…

  5. Office関連

    Office製品の開発チームにユーザーの声を届けよう!

    Office 用アプリやSharePoint 用アプリを開発する際「こ…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP