先日の「表内の文字数を計算する 」の続きです。
上記の記事では、表内の文字数や単語数を正確に表示させました。
項目は「単語数」と「文字数(スペースを含めない)」でした。
このマクロへご要望をいただきましたので、少しつくりかえます。今回のマクロでは、上記項目に加え、「半角英数の単語数」と「全角文字+半角カタカナの数」を表示させます。
このマクロでできること
表内の文字列を部分的に選択して文字カウントをしても、正確に数えます。
マクロの解説
全角の文字数と半角カタカナの文字数を調べるために、27行目でアジア言語の文字数を数えます。
半角英数の単語数は、28行目のように「単語数」から「全角文字+半角カタカナの数」を除いて求めます。
記述は冗長になってしまいました。文字数や単語数を数える別のモジュールを作った方がすっきりしますね。
マクロ
Sub 表内の文字カウント_2() Dim myDoc As Document Dim cChar As Long '文字数(スペースを含めない) Dim cWord As Long '単語数 Dim cZenChar As Long '文字数(全角文字 + 半角カタカナ) Dim cHanWord As Long '単語数(半角英数) If Selection.Type = wdSelectionIP Then '文字列が選択されていない場合→文書全体で計算 With ActiveDocument.Range cWord = .ComputeStatistics(wdStatisticWords) cChar = .ComputeStatistics(wdStatisticCharacters) cZenChar = .ComputeStatistics(wdStatisticFarEastCharacters) cHanWord = cWord - cZenChar End With Else '文字列が選択されている場合→選択範囲で計算 If Selection.Information(wdWithInTable) = False Then 'カーソルが表内にない場合 With Selection.Range cWord = .ComputeStatistics(wdStatisticWords) cChar = .ComputeStatistics(wdStatisticCharacters) cZenChar = .ComputeStatistics(wdStatisticFarEastCharacters) cHanWord = cWord - cZenChar End With Else 'カーソルが表内にある場合 '選択範囲の文字列をコピー Selection.Copy '処理用の新規文書を開く(非表示) Set myDoc = Documents.Add(Visible:=False) 'クリップボードの内容をテキスト形式で貼り付け myDoc.Range.PasteSpecial DataType:=wdPasteText With myDoc.Range cWord = .ComputeStatistics(wdStatisticWords) cChar = .ComputeStatistics(wdStatisticCharacters) cZenChar = .ComputeStatistics(wdStatisticFarEastCharacters) cHanWord = cWord - cZenChar End With '処理用の文書を閉じる myDoc.Close SaveChanges:=wdDoNotSaveChanges Set myDoc = Nothing End If End If '文字数と単語数の表示 MsgBox "単語数" & vbTab & vbTab & vbTab & cWord & vbCr & _ "文字数(スペースを含めない)" & vbTab & cChar & vbCr & _ "半角英数の単語数" & vbTab & vbTab & cHanWord & vbCr & _ "全角文字 + 半角カタカナの数" & vbTab & cZenChar, _ Title:="文字カウント" End Sub