先日の文書中のテキストボックス内の文字列を別紙に書出すマクロ に引き続いて、テキストの抽出用マクロです。
記事をご覧になった読者の方から、質問がありまして作ってみました。
＜目次＞
このマクロでできること
Word文書中の本文中の蛍光ペンで着色された文字列をテキスト（書式無し）として別紙に書出します。
抽出したテキスト毎に改行をして列挙します。
マクロの解説
23行目
特定の文書で検索をした場合、文書最後の蛍光ペンを検出した後、次の蛍光ペンの検出判定が空の文字列に対して起こることがありました。
その場合、無限ループに入ってしまうので、蛍光ペンが見つかった場合には、文字列が少なくとも含まれているかどうかを判定しています。
25行目、26行目
改行記号（vbCR）も蛍光ペンで着色しうるのですが、改行記号の蛍光ペンが検出された場合には無視することにしました。
今回のマクロではあくまでもテキスト情報を取り出すことが目的ですので、改行記号が書出されると読みづらくなりますのでこのような処理としました。
実は、改ページ記号にも蛍光ペンで着色できますので、同様の処理を改ページ記号にしてもいいかもしれません。
30行目、39行目
テキストを書出した後に改行をしています。
ここに、文字列を入れる場合には、代わりに以下のメソッドを追記してもします。
.InsertAfter "追記する文字列"
コンマやタブで区切ることができますね。
マクロ
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | 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 = TrueEnd Sub |
コメント