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

漢字かな交じり文をひらがなにするマクロ前のページ

clipコマンドを利用してクリップボードに文字列をコピーするVBScript次のページ

関連記事

  1. Excel

    Microsoft Edgeを操作するVBAマクロ(WebDriver編)

    Microsoft Edge Dev Blogに「Bringing a…

  2. Office関連

    「IEを自在に操る Excel VBAプログラミング入門」レビュー

    ※ 下記レビューはあくまでも個人的な感想です。2013年9月2…

  3. Office関連

    右クリックから図形の配置 for Office 2013

    HPの掲示板に"右クリックから「配置」を実行できないか?"という質問が…

  4. Office関連

    Excel Web Appのブック埋め込みを試してみました。

    Microsoftが提供しているOffice Web Appsはいわば…

  5. Office関連

    Officeアプリケーションの「最近使用したファイル」を削除するVBScript

    WordやExcel等のOfficeアプリケーションでは、下記サイトに…

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP