【コード】Word文書中の蛍光ペンのテキストを抽出するWordマクロ

先日の文書中のテキストボックス内の文字列を別紙に書出すマクロ に引き続いて、テキストの抽出用マクロです。

記事をご覧になった読者の方から、質問がありまして作ってみました。

このマクロでできること

Word文書中の本文中の蛍光ペンで着色された文字列をテキスト(書式無し)として別紙に書出します。

抽出したテキスト毎に改行をして列挙します。

マクロの解説

23行目

特定の文書で検索をした場合、文書最後の蛍光ペンを検出した後、次の蛍光ペンの検出判定が空の文字列に対して起こることがありました。

その場合、無限ループに入ってしまうので、蛍光ペンが見つかった場合には、文字列が少なくとも含まれているかどうかを判定しています。

25行目、26行目

改行記号(vbCR)も蛍光ペンで着色しうるのですが、改行記号の蛍光ペンが検出された場合には無視することにしました。

今回のマクロではあくまでもテキスト情報を取り出すことが目的ですので、改行記号が書出されると読みづらくなりますのでこのような処理としました。

実は、改ページ記号にも蛍光ペンで着色できますので、同様の処理を改ページ記号にしてもいいかもしれません。

30行目、39行目

テキストを書出した後に改行をしています。

ここに、文字列を入れる場合には、代わりに以下のメソッドを追記してもします。

.InsertAfter “追記する文字列”

コンマやタブで区切ることができますね。

マクロ


Sub 蛍光ペンのテキスト抽出()

 Dim myRange As Range  'Rangeオブジェクト
 Dim myText As String  '抽出する文字列
 Dim newDoc As Document '新規で開いた文書

 '画面の更新をオフ
 Application.ScreenUpdating = False

 Set myRange = ActiveDocument.Range(0, 0)
 Set newDoc = Documents.Add

 With myRange.Find
  .Text = ""
  .Forward = True
  .Wrap = wdFindStop
  .Highlight = True
 End With

 '文書の最後の蛍光ペン後は、蛍光ペンが
 'なくても検索されたと判定されることがあるため回避する処理
 Do While myRange.Find.Execute = True And _
  myRange.Text <> ""

  If InStr(myRange.Text, vbCr) Then
   If myRange.Text <> vbCr Then
    myRange.End = myRange.End - 1
    With newDoc.Range
     .InsertAfter myRange.Text
     .InsertParagraphAfter
     myRange.Collapse direction:=wdCollapseEnd
    End With
   Else
    '蛍光ペンが改行記号の場合は無視
   End If
  Else
   With newDoc.Range
    .InsertAfter myRange.Text
    .InsertParagraphAfter
    myRange.Collapse direction:=wdCollapseEnd
   End With
  End If

 Loop

 Set newDoc = Nothing
 Set myRange = Nothing

 '画面の更新をオン
 Application.ScreenUpdating = True

End Sub

関連記事

文書中のテキストボックス内の文字列を別紙に書出すマクロ

蛍光ペンのある段落を丸ごと抽出するマクロ

トップへ戻る